SUBROUTINE RDSTQS(KFILDO,IP4,IP5,KFILD,NEW,CCALL, 1 NAME,IBLOCK,ELEV,IWBAN,STALAT,STALON, 2 ITIMEZ,ITYPE,IFOUND,ND1,NSTA,IER) C C AUGUST 2014 GLAHN MDL MOS-2000 C MODIFIED FROM RDSTQN FOR U155 TO C RETURN TYPE OF STATION FIELD C IN ITYPE( ) C PURPOSE C TO READ A STATION LIST AND ASSOCIATED INFORMATION FROM A C STATION DIRECTORY. THE LIST (8 CALL LETTERS) CAN BE TAKEN C FROM THE DIRECTORY, IN WHICH CASE ALL STATIONS IN THE C DIRECTORY WILL BE USED, OR CAN BE ON THE DEFAULT INPUT C FILE, OR CAN BE ON A COMPLETELY SEPARATE FILE. NOTE C THAT A SEPARATE STATION LIST CANNOT BE ON THE SAME FILE C AS THE DIRECTORY. THE STATION LIST IS PUT INTO CCALL( ,1), C WITH UP TO 5 SUBSTITUTE STATIONS IN CCALL( ,J),J=2,6). C CCALL( , ) SHOULD BE DECLARED CHARACTER*8 IN THE CALLING C PROGRAM. WHEN THE STATION LIST IS NOT TAKEN FROM THE C DIRECTORY (THE USUAL CIRCUMSTANCE), THE CALL TO RDC C IS SET TO READ UP TO NT = 7 VALUES PER RECORD ACCORDING C TO THE FORMAT (7(A8,1X)); HOWEVER, THE RECORD NEED NOT C HAVE THAT MANY VALUES. THE STATIONS IN THE LIST RETURNED C IN CCALL( ,1) WILL BE IN THE ORDER READ IN. DUPLICATE C STATIONS IN THE SEPARATE LIST WILL BE KEPT, BUT A C DIAGNOSTIC IS OUTPUT. NOTE THAT THIS ROUTINE CAN BE C USED FOR A "GROUP" OF STATIONS, NOT NECESSARILY THE C COMPLETE LIST. IN THAT CASE, THE CALLING PROGRAM WILL C PROVIDE THE LOCATIONS IN THE ARRAYS WHERE THE GROUP C LIST IS TO START, AND ND1 WILL BE THE SPACE LEFT THAT C CAN BE FILLED. A "DUPLICATE" IS COUNTED AS SUCH ONLY C WITHIN A GROUP. IT IS ASSUMED ARRAYS TO BE FILLED ARE C INITIALIZED BEFORE ENTRY. THE LIST RETURNED IN C CCALL( ,1) WILL ALWAYS CONFORM TO THE VARIABLE "NEW." C THAT IS, WHEN NEW = 1, THE STATIONS RETURNED IN C CCALL( , 1) WILL ALWAYS BE ICAO CALL LETTERS (PROVIDED C THE DIRECTORY HAS ICAO CALL LETTERS FIRST) AND THE C STATIONS RETURNED IN CCALL( ,2), THE FIRST ALTERNATE, C WILL ALWAYS BE THE OLD CALL LETTERS (PROVIDED THEY C ARE THE FIRST ALTERNATE IN THE DIRECTORY). C C NOTE THAT, IN THE STATION DIRECTORY, IF THERE IS THE C SAME LINK IN MORE THAN ONE DIRECTORY ENTRY, OR EVEN C IF THE OLD CALL LETTERS ENTRY IS THE SAME AS A LINK TO C ANOTHER ICAO ENTRY, THE DESIRED STATION MAY NOT BE C ACCESSED. THIS IS AN AMBIGUITY NOT DEALT WITH. C C NOTE: THE DIFFERENCE BETWEEN THIS RDSTQN/RDSTQS AND RDSTQA C IS THAT RDSTQA ALPHABETIZES STATIONS, WHILE RDSTQN C DOES NOT. RDSTQN DIFFERS FROM OTHER READERS C IN THAT DATA FROM THE BLOCK/STATION NUMBER C FIELD IS RETURNED WHILE OTHERS DO NOT RETURN C SUCH DATA. IN U155, THIS FIELD IS USED FOR QUALITY C CONTROL FLAGS. ALSO, THE ELEVATIONS ARE RETURNED C AS REAL IN METERS. C C DATA SET USE C KFILDO - DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (OUTPUT) C IP4 - UNIT NUMBER FOR OUTPUT OF CALL LETTERS. (OUTPUT) C IP5 - UNIT NUMBER FOR OUTPUT OF DIRECTORY INFORMATION C (OUTPUT) C KFILD(J) - UNIT NUMBER FROM WHICH TO READ STATION LIST C (J=1) AND STATION DIRECTORY (J=2). IT IS ASSUMED C FILES HAVE BEEN OPENED. (INPUT) C C VARIABLES C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (INPUT) C IP4 = INDICATES WHETHER (>0) OR NOT (=0) THE STATION C LIST (CALL LETTERS ONLY) WILL BE WRITTEN TO UNIT C IP4 WHEN THE STATION LIST IS NOT TAKEN FROM C THE DIRECTORY. HOWEVER, IF THERE ARE INPUT C ERRORS, THE STATION LIST WILL ALWAYS BE WRITTEN C TO IP4 AS WELL AS TO THE DEFAULT OUTPUT FILE C UNIT KFILDO. (INPUT) C IP5 = INDICATES WHETHER (>0) OR NOT (=0) THE STATION C DIRECTORY INFORMATION WILL BE WRITTEN TO UNIT C IP5. IF THERE ARE INPUT ERRORS, THE STATION LIST C WILL BE WRITTEN TO THE DEFAULT OUTPUT FILE UNIT C KFILDO AS WELL AS TO UNIT IP5. (INPUT) C KFILD(J) = UNIT NUMBER FROM WHICH TO READ STATION LIST (J=1) C AND STATION DIRECTORY (J=2). IT IS ASSUMED FILES C HAVE BEEN OPENED. (INPUT) C NEW = 1 WHEN NEW ICAO CALL LETTERS ARE TO BE USED; C 0 WHEN OLD 3-LETTER CALL LETTERS ARE TO BE USED. C NOTE THAT WHEN THERE ARE NO 3-LETTER CALL C LETTERS TO MATCH AN ICAO INPUT LIST, THE C CALL LETTERS WILL BE BLANK, AND EVEN C THOUGH THE STATION INFORMATION WILL BE THERE, C IT WILL BE USELESS BECAUSE THERE ARE NO C CALL LETTERS IN CCALL( , 1). C (INPUT) C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT C LOCATIONS FOR GRID DEVELOPMENT) TO PROVIDE C OUTPUT FOR (J=1) AND 5 POSSIBLE OTHER STATION C CALL LETTERS (J=2,6) THAT CAN BE USED INSTEAD C IF THE PRIMARY (J=1) STATION CANNOT BE FOUND C IN AN INPUT DIRECTORY (K=1,NSTA). ALL STATION C DATA ARE KEYED TO THIS LIST. (CHARACTER*8) C (OUTPUT) C NAME(K) = NAMES OF STATIONS (K=1,NSTA) (CHARACTER*20) C (OUTPUT) C IBLOCK(K) = DATA FROM THE BLOCK/STATION NUMBER FIELD. C THE FIELD FOR IBLOCK( ) READ FROM THE DICTIONARY C WAS ORIGINALLY FOR THE BLOCK/STATION NUMBER, BUT C WAS NOT USED AND IS USED IN U155 FOR QUALITY C CONTROL FLAGS. (OUTPUT) C ELEV(K) = ELEVATION OF STATIONS READ IN FEET AND C CONVERTED TO METERS. (K=1,NSTA). (OUTPUT) C IWBAN(K) = WBAN NUMBERS OF STATIONS (K=1,NSTA). (OUTPUT) C STALAT(K) = LATITUDE OF STATIONS (K=1,NSTA). (OUTPUT) C STALON(K) = LONGITUDE OF STATIONS (K=1,NSTA). (OUTPUT) C ITIMEZ(K) = TIME ZONE INDICATOR. THE NUMBER OF HOURS C THE STATION IS DIFFERENT FROM UTC (K=1,NSTA). C (OUTPUT) C ITYPE(K) = TKYPE OF STATION (K=1,NSTA). C IFOUND(K) = USED TO KEEP TRACK OF THE STATIONS FOUND IN THE C DIRECTORY (K=1,NSTA). C 0 = NOT YET FOUND, C L=1-6 = FOUND, COLUMN OF CCALL( ,L) WHERE C CCALLD( ) FOUND. C 7 = DUPLICATE. C 8 = DUPLICATE PROBABLY CAUSED BY A LINK TO AN C ALTERNATE STATION. AN ALTERNATE STATION IS C DEFINED AS COLS. 2-6 WHEN NEW = 1, AND AS C COLS. 1 AND 3-6 WHEN NEW = 0. C (INTERNAL) C ND1 = SIZE OF ARRAYS CCALL( , ), ELEV( ), IWBAN( ), c STALAT( ), STALON( ) AND IFOUND( ). C THIS IS THE MAXIMUM NUMBER OF STATIONS IN THE C LIST TO BE RETURNED. (INPUT) C NSTA = COUNT OF ELEMENTS IN ARRAY RETURNED. (OUTPUT) C IER = STATUS RETURN. (OUTPUT) C 0 = GOOD RETURN. C 20 = ERROR OR EOF READING KFILD(1) IN RDC C (ABORTS) C 21 = TOO MANY STATIONS FOR CCALL(ND1) IN RDC C (ABORTS) C 33 = ERROR ON UNIT KFILD(2) WHEN READING THE C DIRECTORY (ABORTS) C 34 = TOO MANY STATIONS IN DIRECTORY TO BE C ACCOMMODATED BY ND1 WHEN USING ALL C STATIONS FROM THE DIRECTORY (ABORTS C WITH PRINT) C THE FOLLOWING VALUES PERTAIN ONLY WHEN C KFILD(1) NE KFILD(2) (I.E., STATION LIST NOT C FROM DIRECTORY). C 35 = ONE OR MORE STATIONS NOT FOUND IN THE C DIRECTORY (NORMAL RETURN) C 36 = LINK IN THE DIRECTORY USED FOR ONE OR MORE C STATIONS (NORMAL RETURN) C 37 = BOTH IER 35 AND 36 HAVE OCCURRED (NORMAL C RETURN) C NOTE THAT DUPLICATE STATIONS DO NOT HAVE C AN IER CODE, BUT A DIAGNOSTIC IS WRITTEN. C CTEMP( ) = TEMPORARY ARRAY THAT MUST BE OF AT LEAST SIZE NT. C (CHARACTER*8) (INTERNAL) C NT = NUMBER OF WORDS PER RECORD INDICATED IN FORMAT. C SET BY PARAMETER, BECAUSE IS IS A DIMENSION. C (INTERNAL) C CCALLT(J) = TO READ CALL LETTERS INTO FROM DIRECTORY (J=1,6). C FOR NEW = 1, THE KEY OR PRIMARY CALL LETTERS (J=1) C ARE FROM COLUMNS 1-8 AND THE SECONDARY CALL LETTERS C (USUALLY THE CALL LETTERS BEFORE THE SHIFT TO ICAO C STATION IDENTIFIERS) (J=2) ARE FROM COLUMNS 10-17. C FOR NEW = 0, THE PRIMARY CALL LETTERS ARE FROM C COLUMNS 10-17, AND THE SECONDARY ARE FROM 1-8. C OTHER OPTIONAL CALL LETTERS (J=3,6) ARE FROM COLUMNS C 83-90, 92-99, 101-108, and 110-117. (CHARACTER*8) C (INTERNAL) C NAMET = TO READ NAME INTO FROM DIRECTORY. (CHARACTER*20) C (INTERNAL) C ELEVT = TO READ ELEVATION INTO FROM DIRECTORY. (INTERNAL) C IWBANT = TO READ WBAN NUMBER INTO FROM DIRECTORY. (INTERNAL) C ITIMEX = TO READ TIME ZONE INDICATOR INTO FROM DIRECTORY. C (INTERNAL) C SIGNLA = SIGN OF THE LATITUDE AS READ FROM THE DIRECTORY. C WILL BE "N" FOR NORTH LATITUDE OR "S" FOR SOUTH C LATITUDE. WHEN "S", THE LATITUDE WILL BE STORED C AS NEGATIVE. (CHARACTER*1) (INTERNAL) C XLATDD = LATITUDE IN DEGREES. (INTERNAL) C SIGNLO = SIGN OF THE LONGITUDE AS READ FROM THE DIRECTORY. C WILL BE "E" FOR EAST LONGITUDE OR "W" FOR WEST C LONGITUDE. WHEN "E", THE LONGITUDE IS ADJUSTED C SO THAT ALL VALUES ARE WEST. (CHARACTER*1) (INTERNAL) C XLONDD = LONGITUDE IN DEGREES. (INTERNAL) C BLANK8 = 8 BLANKS. (CHARACTER*8) (INTERNAL) C BLANK = 20 BLANKS (CHARACTER*20) (INTERNAL) C MSTA = COUNTS THE STATIONS IN THE CCALL( , ) LIST FOUND C IN THE DIRECTORY. WHEN ALL NSTA STATIONS C HAVE BEEN FOUND, THE READING OF THE DIRECTORY C CAN STOP. C JER = CONTROLS LINE SPACING WHEN PRINTING DIAGNOSTIC C FOR STATIONS NOT FOUND IN DIRECTORY OR DUPLICATE C STATIONS. C CCALLS(K) = HOLDS THE CALL LETTERS TO BE PUT INTO C CCALL(K,1) BEFORE EXIT. THIS IS NECESSARY SO C THAT CCALL(K,1) WON'T BE OBLITERATED DUE TO C A LINK THAT IS SUBSEQUENTLY FOUND AS A PRIMARY. C (CHARACTER*8) (AUTOMATIC) (INTERNAL) C LINKNO(K) = USED FOR KEEPING TRACK OF THE LINK NUMBER C FOR EACH STATION (K=1,NST) (AUTOMATIC) C (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES CALLED C RDC. C PARAMETER (NT=7) C CHARACTER*1 SIGNLA,SIGNLO CHARACTER*4 STATE CHARACTER*8 CCALL(ND1,6),CTEMP(NT),BLANK8,CCALLT(6) CHARACTER*8 CCALLS(ND1) C CCALLS( ) IS AN AUTOMATIC ARRAY. CHARACTER*20 NAME(ND1),NAMET,BLANK C DIMENSION ELEV(ND1),IWBAN(ND1),ITIMEZ(ND1), 1 STALAT(ND1),STALON(ND1),IFOUND(ND1),IBLOCK(ND1), 2 ITYPE(ND1) DIMENSION LINKNO(ND1) C LINKNO( ) IS AN AUTOMATIC ARRAY. DIMENSION KFILD(2) C DATA BLANK8/' '/ DATA BLANK/' '/ DATA CCALLT/6*' '/ C D CALL TIMPR(KFILDO,KFILDO,'START RDSTQS ') C IER=0 JER=0 MSTA=0 C C INITIALIZE ARRAYS. C DO 105 K=1,ND1 C DO 102 L=1,6 CCALL(K,L)=BLANK8 102 CONTINUE C CCALLS(K)=BLANK8 NAME(K)=BLANK IBLOCK(K)=0 ELEV(K)=0. IWBAN(K)=0 STALAT(K)=0. STALON(K)=0. ITIMEZ(K)=0 ITYPE(K)=0 IFOUND(K)=0 LINKNO(K)=0 105 CONTINUE C IF(KFILD(1).EQ.KFILD(2))GO TO 120 C C READ STATION LIST, APART FROM DIRECTORY. THIS MAY BE FROM THE C DEFAULT INPUT FILE (UNIT NUMBER KFILDI) OR FROM A SEPARATE FILE, C UNIT NUMBER KFILD(1). C CALL RDC(KFILDO,IP4,KFILD(1),CCALL,ND1,CTEMP,NT,'(7(A8,1X))', 1 NSTA,'99999999',IER) C NT = 7 WITH FMT = '(7(A8,1X))' MEANS THAT UP TO 7 VALUES WILL C BE READ PER RECORD. FEWER CAN BE PRESENT. IF THE LAST C VALUE IS NOT COMPLETE, IT WILL BE BLANK FILLED ON THE RIGHT. C THAT IS, 'OKC ' COULD BE 'OKC' OR 'OKC '. C IF(IER.NE.0)THEN WRITE(KFILDO,110)NSTA,(CCALL(K,1),K=1,NSTA) 110 FORMAT(/,' ',I5,' STATIONS INPUT',/,(14(1X,A8))) IF(IP4.NE.0.AND.IP4.NE.KFILDO) 1 WRITE(IP4,110)NSTA,(CCALL(K,1),K=1,NSTA) C WHEN IER NE 0, A DIAGNOSTIC WILL HAVE BEEN WRITTEN BY RDC. GO TO 160 ENDIF C IF(NSTA.EQ.0)GO TO 160 C AN EMPTY SET TERMINATES READING. IF(IP4.EQ.0)GO TO 120 WRITE(IP4,110)NSTA,(CCALL(K,1),K=1,NSTA) C C READ DIRECTORY. IT IS ASSUMED THE DIRECTORY IS ALPHABATIZED C BY CALL LETTERS. FOR THE CURRENT DIRECTORY, THIS IS BY THE C ICAO CALL LETTERS. C 120 STATE='120 ' J=0 121 CCALLT(1)=BLANK8 CCALLT(2)=BLANK8 NAMET(1:20)=BLANK C THE ABOVE STATEMENTS ARE AS A PRECAUTION AND ARE PROBABLY C NOT REALLY NEEDED. IF(NEW.EQ.1)THEN READ(KFILD(2),122,IOSTAT=IOS,ERR=123,END=140)CCALLT(1), 1 CCALLT(2),NAMET(1:17),NAMET(19:20),NBLOCK, 2 ELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEX,ITYPEX, 3 OPEN,(CCALLT(K),K=3,6),IDATE,IWBANT 122 FORMAT(A8,1X,A8,1X,A17,4X,A2,1X,I6,1X,F5.0,1X,A1,F7.4,1X,A1, 1 F8.4,1X,I3,1X,I1,1X,A1,4(1X,A8),1X,I10,1X,I5) ELSE READ(KFILD(2),122,IOSTAT=IOS,ERR=123,END=140)CCALLT(2), 1 CCALLT(1),NAMET(1:17),NAMET(19:20),NBLOCK, 2 ELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEX,ITYPEX, 3 OPEN,(CCALLT(K),K=3,6),IDATE,IWBANT ENDIF C GO TO 130 C 123 WRITE(KFILDO,124)IOS IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,124)IOS IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5)WRITE(IP5,124)IOS 124 FORMAT(/,' ****ERROR READING STATION DIRECTORY IN RDSTQS.', 1 ' IOSTAT =',I5) IER=33 IF(KFILD(1).EQ.KFILD(2))NSTA=J GO TO 160 C 130 IF(KFILD(1).NE.KFILD(2))GO TO 1307 C C ************************************************************* C C DIRECTORY IS TO BE USED FOR LIST. C C ************************************************************* C J=J+1 IF(J.LE.ND1)GO TO 1305 C ND1 ABOUT TO BE EXCEEDED. WRITE(KFILDO,1302)ND1 IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1302)ND1 IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5)WRITE(IP5,1302)ND1 1302 FORMAT(/,' ****TOO MANY STATIONS IN DIRECTORY FOR DIMENSION ND1 =' 1 ,I7,'.') J=J-1 NSTA=J IER=34 GO TO 148 C 1305 CCALL(J,1)=CCALLT(1) CCALL(J,2)=CCALLT(2) CCALL(J,3)=CCALLT(3) CCALL(J,4)=CCALLT(4) CCALL(J,5)=CCALLT(5) CCALL(J,6)=CCALLT(6) NAME(J)=NAMET IBLOCK(J)=NBLOCK IWBAN(J)=IWBANT ITIMEZ(J)=ITIMEX ITYPE(J)=ITYPEX ELEV(J)=ELEVT STALAT(J)=XLATDD IF(SIGNLA.EQ.'S')STALAT(J)=-STALAT(J) C ABOVE STATEMENT MAKES SOUTH LATITUDE NEGATIVE. STALON(J)=XLONDD IF(SIGNLO.EQ.'E')STALON(J)=360.-STALON(J) C ABOVE STATEMENT MAKES ALL LONGITUDES WEST, RANGE 0-360. IFOUND(J)=1 NSTA=J GO TO 121 C C ************************************************************* C C DIRECTORY IS NOT TO BE USED FOR LIST; A SEPARATE LIST EXISTS. C C ************************************************************* C C A STATION LIST ALREADY RESIDES IN CCALL( ,1). IF THE C STATION EXISTS IN THE DIRECTORY AS EITHER THE ICAO C IDENTIFIER OR AS THE VALUE PROVIDED AS THE FIRST ALTERNATE C (USUALLY THE OLD CALL LETTERS), FILL NAME( ), IWBAN( ), C ELEV( ), STALAT( ), STALON( ), AND (CCALL( ,L), L=2,6). C NOTE THAT WHEN NEW = 1, CCALLT(1) WILL CONTAIN ICAO C IDENTIFIERS AND CCALLT(2) WILL CONTAIN OLD CALL LETTERS, C AND WHEN NEW = 0, CCALLT(1) WILL CONTAIN OLD CALL LETTERS C AND CCALLT(2) WILL CONTAIN ICAO IDENTIFIERS. C 1307 JP1=0 C JP1 IS SET TO 0 FOR EVERY DIRECTORY ENTRY READ. C DO 1395 L=1,6 IF(L.LE.2)GO TO 1308 C ALWAYS CHECK THE FIRST TWO COLUMNS OF THE DIRECTORY. IF(CCALLT(L).EQ.BLANK8)GO TO 121 C ONCE A BLANK IS FOUND IN THE ALTERNATE STATION COLUMNS, C THE SEARCH IS OVER. READ ANOTHER DIRECTORY ENTRY. C 1308 DO 139 K=1,NSTA C IF(IFOUND(K).GT.0.AND.LINKNO(K).EQ.0)GO TO 139 C ABOVE TEST GUARDS AGAINST DUPLICATES IN THE DIRECTORY. C IF THERE IS A DUPLICATE, THE FIRST ENTRY IS USED. C C CHECK FOR STATIONS. C IF(CCALLT(L).NE.CCALL(K,1))GO TO 139 C IF(LINKNO(K).NE.0.AND.LINKNO(K).LT.L)GO TO 139 C JP1=JP1+1 CCALLS(K)=CCALLT(1) C CCALLS(K) IS FILLED ACCORDING TO VARIABLE CCALLT(1). C BEFORE EXIT, THIS IS INSERTED INTO CCALL(K,1). C CCALLS( ) IS NECESSARY BECAUSE A LINK TO AN ALTERNATE C STATION MAY BE FOUND BEFORE THE PRIMARY CALL LETTERS. C WHEN THAT HAPPENS, CCALL(K,2-6) WILL BE OVERWRITTEN C PROPERLY, BUT CCALL(K,1) CAN'T BE DISTURBED UNTIL THE C SEARCH IS COMPLETED. CCALL(K,2)=CCALLT(2) MSTA=MSTA+1 CCALL(K,3)=CCALLT(3) CCALL(K,4)=CCALLT(4) CCALL(K,5)=CCALLT(5) CCALL(K,6)=CCALLT(6) NAME(K)=NAMET IBLOCK(K)=NBLOCK IWBAN(K)=IWBANT ITIMEZ(K)=ITIMEX ITYPE(K)=ITYPEX ELEV(K)=ELEVT STALAT(K)=XLATDD IF(SIGNLA.EQ.'S')STALAT(K)=-STALAT(K) C ABOVE STATEMENT MAKES SOUTH LATITUDE NEGATIVE. STALON(K)=XLONDD IF(SIGNLO.EQ.'E')STALON(K)=360.-STALON(K) C ABOVE STATEMENT MAKES ALL LONGITUDES WEST, RANGE 0-360. C IF(L.EQ.1)THEN LINKNO(K)=0 ELSE LINKNO(K)=L ENDIF C IF(JP1.EQ.1)THEN IFOUND(K)=L ELSE C IF(L.EQ.1)THEN IFOUND(K)=7 ELSE IFOUND(K)=8 ENDIF C ENDIF C C IFOUND( ) CORRESPONDS TO THE ORIGINAL LIST AS READ. C EVEN THOUGH THIS DIRECTORY ENTRY HAS BEEN USED AND ENTERED C INTO THE LIST, THE SEARCH IS CONTINUED IN CASE THERE C ARE DUPLICATE STATIONS IN THE LIST. C 139 CONTINUE C 1395 CONTINUE C C EITHER THE END OF THE DIRECTORY, OR HAVING FOUND C ALL THE NSTA STATIONS CAN HALT READING OF THE C DIRECTORY. C IF(MSTA.LT.NSTA)GO TO 121 C C DETERMINE AND PRINT WHETHER THERE ARE STATIONS C IN THE LIST THAT WERE NOT FOUND IN THE DIRECTORY. C SET IER TO THE VALUES INDICATED IN THE PROLOGUE. C 140 IF(KFILD(1).EQ.KFILD(2))GO TO 148 C C THIS LOOP NEEDED ONLY WHEN A SEPARATE LIST IS USED. C DO 145 K=1,NSTA C IF(ELEV(K).NE.9999.)THEN ELEV(K)=ELEV(K)*.30480 C THIS CONVERTS FEET TO METERS. ENDIF C IF(IFOUND(K).EQ.0)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,141)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,141)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,141)CCALL(K,1) 141 FORMAT(/,' ****STATION ',A8,' NOT FOUND IN DIRECTORY') ELSE WRITE(KFILDO,1410)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1410)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1410)CCALL(K,1) 1410 FORMAT(' ****STATION ',A8,' NOT FOUND IN DIRECTORY') ENDIF C JER=1 CCALL(K,2)=BLANK8 CCALL(K,3)=BLANK8 CCALL(K,4)=BLANK8 CCALL(K,5)=BLANK8 CCALL(K,6)=BLANK8 C ABOVE STATEMENTS NECESSARY TO OBLITERATE ANY INFO C LEFT OVER IN CCALL( , ). ELSE CCALL(K,1)=CCALLS(K) C THE STATION CALL LETTERS WERE SAVED IN CALLS( ) C ACCORDING TO NEW. C IF(IFOUND(K).EQ.7)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,142)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,142)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,142)CCALL(K,1) 142 FORMAT(/' ****STATION ',A8,' IS A DUPLICATE.') ELSE WRITE(KFILDO,1420)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1420)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1420)CCALL(K,1) 1420 FORMAT(' ****STATION ',A8,' IS A DUPLICATE.') ENDIF C JER=1 C ELSEIF(IFOUND(K).EQ.8)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,143)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,143)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,143)CCALL(K,1) 143 FORMAT(/' ****STATION ',A8,' IS A DUPLICATE', 1 ' MAY BE CAUSED BY A LINK TO ALTERNATE STATION.') ELSE WRITE(KFILDO,1430)CCALL(K,1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1430)CCALL(K,1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1430)CCALL(K,1) 1430 FORMAT(' ****STATION ',A8,' IS A DUPLICATE', 1 ' MAY BE CAUSED BY A LINK TO ALTERNATE STATION.') ENDIF C JER=1 C ELSEIF(IFOUND(K).NE.1)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,144)CCALL(K,1),IFOUND(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,144)CCALL(K,1), 1 IFOUND(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,144)CCALL(K,1),IFOUND(K) 144 FORMAT(/' ****STATION ',A8,' REQUIRED A LINK NO. =',I3, 1 '.') ELSE WRITE(KFILDO,1440)CCALL(K,1),IFOUND(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1440)CCALL(K,1), 1 IFOUND(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1440)CCALL(K,1),IFOUND(K) 1440 FORMAT(' ****STATION ',A8,' REQUIRED A LINK NO. =',I3, 1 '.') ENDIF C JER=1 ENDIF C ENDIF C 145 CONTINUE C C SET ERROR CODE IER. WHEN IER = 33 OR 34, LEAVE IT; C THESE ARE CONSIDERED TO BE FATAL ERRORS. C IF(IER.EQ.33.OR.IER.EQ.34)GO TO 148 C C ADJUST IER AS NECESSARY. C IER = 35 - ONE OR MORE STATIONS NOT FOUND. C = 36 - LINK USED FOR ONE OR MORE STATIONS. C = 37 - BOTH OF ABOVE. C DO 147 K=1,NSTA C IF(IFOUND(K).EQ.0)THEN C IF(IER.GT.35)THEN IER=37 GO TO 148 ELSE IER=35 ENDIF C ELSEIF(IFOUND(K).EQ.8)THEN C IF(IER.EQ.0.OR.IER.EQ.36)THEN IER=36 ELSE IER=37 GO TO 148 ENDIF C ENDIF C 147 CONTINUE C C WRITE DIRECTORY INFORMATON TO KFILDO ONLY IF THE C ERROR IS CONSIDERED FATAL (IER = 33 OR 34). C STATION DIRECTORY MAY BE WRITTEN TWICE WHEN THERE ARE ERRORS C DETECTED, ONCE TO THE DEFAULT OUTPUT FILE AND ONCE TO UNIT C IP5. C 148 IF(IER.EQ.0)THEN C IF(IP5.NE.0)THEN WRITE(IP5,151) 1 NSTA,IER,(J,CCALL(J,1),NAME(J), 2 IWBAN(J),IBLOCK(J),STALAT(J),STALON(J),ELEV(J),ITIMEZ(J), 3 (CCALL(J,I),I=2,6),J=1,NSTA) ENDIF C ELSEIF(IER.EQ.33.OR.IER.EQ.34)THEN WRITE(KFILDO,151) 1 NSTA,IER,(J,CCALL(J,1),NAME(J), 2 IWBAN(J),IBLOCK(J),STALAT(J),STALON(J),ELEV(J),ITIMEZ(J), 3 (CCALL(J,I),I=2,6),J=1,NSTA) 151 FORMAT(/' ',I7,' STATIONS AND DIRECTORY INFORMATION, IER =',I3/ 1 ' NO. STA NAME WBAN', 2 ' QUAL FLAGS', 3 ' LAT LON ELEV ZONE SUBSTITUTE STATIONS'/ 4 (1X,I6,2X,A8,1X,A20,1X,I5,I10,1X,2F8.2,F7.0,I4,2X, 5 5(1X,A8))) C IF(IP5.NE.0.AND.IP5.NE.KFILDO)THEN WRITE(IP5,151) 1 NSTA,IER,(J,CCALL(J,1),NAME(J), 2 IWBAN(J),IBLOCK(J),STALAT(J),STALON(J),ELEV(J),ITIMEZ(J), 3 (CCALL(J,I),I=2,6),J=1,NSTA) ENDIF C ELSE IF(IP5.NE.0)THEN WRITE(IP5,151) 1 NSTA,IER,(J,CCALL(J,1),NAME(J), 2 IWBAN(J),IBLOCK(J),STALAT(J),STALON(J),ELEV(J),ITIMEZ(J), 3 (CCALL(J,I),I=2,6),J=1,NSTA) ENDIF C ENDIF C D CALL TIMPR(KFILDO,KFILDO,'END RDSTQS ') C 160 RETURN END