SUBROUTINE RDSTQT(KFILDO,IP4,IP5,KFILD,NEW,CCALL,CCALLD, 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 RDSTQA 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 ALPHABETICAL ORDER PROVIDED THE C DIRECTORY IS ALPHABETICAL. THE CURRENT DIRECTORY C IS ALPHABETICAL BY THE NEW ICAO CALL LETTERS; C SO, IF THE OLD CALL LETTERS ARE USED, THE STATIONS WILL C NOT BE IN ALPHABETICAL ORDER. DUPLICATE STATIONS IN THE C SEPARATE LIST WILL BE KEPT, BUT A DIAGNOSTIC IS OUTPUT. C NOTE THAT THIS ROUTINE CAN BE USED FOR A "GROUP" OF C STATIONS, NOT NECESSARILY THE COMPLETE LIST. IN THAT C CASE, THE CALLING PROGRAM WILL PROVIDE THE LOCATIONS C IN THE ARRAYS WHERE THE GROUP LIST IS TO START, AND C ND1 WILL BE THE SPACE LEFT THAT CAN BE FILLED. C A "DUPLICATE" IS COUNTED AS SUCH ONLY WITHIN A GROUP. 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 RDSTQA/RDSTQT AND RDSTQN IS C THAT RDSTQA ALPHABETIZES STATIONS, WHILE RDSTQN C DOES NOT. RDSTQA 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. C (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 C ASSUMED 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 C LIST WILL BE WRITTEN TO THE DEFAULT OUTPUT FILE C UNIT KFILDO AS WELL AS TO UNIT IP5. (INPUT) C KFILD(J) = UNIT NUMBER FROM WHICH TO READ STATION LIST C (J=1) AND STATION DIRECTORY (J=2). IT IS C ASSUMED FILES 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, EXCEPT POSSIBLY C CCALLD( ). (CHARACTER*8) C (OUTPUT) C CCALLD(K) = CALL LETTERS AS READ. DIMENSIONED ND1 BECAUSE C IT NEEDS NOT BE GT THE NUMBER OF STATIONS BEING C USED; IT MAY BE DIMENSIONED LARGER IN THE C CALLING PROGRAM (I.E., ND5). (CHARACTER*8) C (INTERNAL) 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( , ), CCALLD( ), ELEV( ), C IWBAN( ), 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 C NT. (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 C (J=1,6). FOR NEW = 1, THE KEY OR PRIMARY CALL C LETTERS (J=1) ARE FROM COLUMNS 1-8 AND THE C SECONDARY CALL LETTERS USUALLY THE CALL LETTERS C BEFORE THE SHIFT TO ICAO STATION IDENTIFIERS) C (J=2) ARE FROM COLUMNS 10-17. FOR NEW = 0, THE C PRIMARY CALL LETTERS ARE FROM COLUMNS 10-17, AND C THE SECONDARY ARE FROM 1-8. OTHER OPTIONAL CALL C LETTERS (J=3,6) ARE FROM COLUMNS 83-90, 92-99, C 101-108, AND 110,117. (CHARACTER*8) (INTERNAL) C NAMET = TO READ NAME INTO FROM DIRECTORY. C (CHARACTER*20) (INTERNAL) C ELEVT = TO READ ELEVATION INTO FROM DIRECTORY. C (INTERNAL) C IWBANT = TO READ WBAN NUMBER INTO FROM DIRECTORY. C (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 C DIRECTORY. WILL BE "E" FOR EAST LONGITUDE OR C "W" FOR WEST LONGITUDE. WHEN "E", THE LONGITUDE C IS ADJUSTED SO THAT ALL VALUES ARE WEST. C (CHARACTER*1) (INTERNAL) C XLONDD = LONGITUDE IN DEGREES. (INTERNAL) C NSTX = KEEPS KOUNT OF NUMBER OF STATIONS FOUND IN THE C DIRECTORY. (INTERNAL) C BLANK8 = 8 BLANKS. (CHARACTER*8) (INTERNAL) C BLANK = 20 BLANKS (CHARACTER*20) (INTERNAL) C LINK(K) = USED FOR REPLACING LINKS WITH PRIMARY CALL C LETTERS (K=1,NSTA). (AUTOMATIC) (INTERNAL) C LINKNO(K) = USED FOR KEEPING TRACK OF THE LINK NUMBER C FOR EACH STATION (K=1,NST) (AUTOMATIC) C (INTERNAL) C JSTA = KEEPS TRACK OF THE NUMBER OF ENTRIES IN C CCALL( , ). (INTERNAL) C LOC(K) = LOCATION IN LIST CCALL( , ) WHERE STATION K C WENT. (AUTOMATIC) (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),CCALLD(ND1),CTEMP(NT),BLANK8,CCALLT(6) 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 LINK(ND1),LINKNO(ND1),LOC(ND1) C LINK( ), LINKNO( ), AND LOC( ) ARE AUTOMATIC ARRAYS. DIMENSION KFILD(2) C DATA BLANK8/' '/ DATA BLANK/' '/ C D CALL TIMPR(KFILDO,KFILDO,'START RDSTQT ') C IER=0 NSTX=0 JSTA=0 C C INITIALIZE ARRAYS. C DO 105 K=1,ND1 C DO 102 L=1,6 CCALL(K,L)=BLANK8 102 CONTINUE C NAME(K)=BLANK CCALLD(K)=BLANK8 IBLOCK(K)=0 ELEV(K)=0. IWBAN(K)=0 STALAT(K)=0. STALON(K)=0. ITIMEZ(K)=0 ITYPE(K)=0 IFOUND(K)=0 LINK(K)=0 LINKNO(K)=0 LOC(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),CCALLD,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,(CCALLD(K),K=1,NSTA) 110 FORMAT(/,' ',I5,' STATIONS INPUT',/,(14(1X,A8))) IF(IP4.NE.0.AND.IP4.NE.KFILDO) 1 WRITE(IP4,110)NSTA,(CCALLD(K),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,(CCALLD(K),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 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) C NOTE THAT IBLOCK IS READ I6; HOWEVR, THE VALUES ARE C IN THE C-COLUMN FIELD STARTING AT THE LEFT, WITH BLANKS C TO THE RIGHT. THIS MEANS A SINGLE DIGIT WILL BE READ C AS A SINGLE DIGIT INTEGER AND TWO DIGITS WILL BE READ C AS A TWO-DIGIT INTEGER. 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 C ERROR READING DIRECTORY. 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 RDSTQT.', 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. C 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,'.') IER=34 GO TO 148 C 1305 CCALLD(J)=CCALLT(1) 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)(1:17)=NAMET(1:17) NAME(J)(19:20)=NAMET(19:20) 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. NSTX=J NSTA=J LOC(J)=J IFOUND(J)=1 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 CCALLD( ). THE STATIONS C WILL BE KEPT ALPHABETICALLY, PROVIDED THE DIRECTORY C IS ALPHABETICAL. DUPLICATE STATIONS WILL BE KEPT. STATIONS C NOT IN THE DIRECTORY WILL APPEAR AT THE END OF THE LIST. IF C THE STATION EXISTS IN THE DIRECTORY AS EITHER THE ICAO C IDENTIFIER OR AS ONE OF THE ALTERNATES, 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.LINK(K).EQ.0)GO TO 139 C 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.CCALLD(K))GO TO 139 C IF(LINK(K).NE.0)THEN C C THIS STATION K WAS FOUND PREVIOUSLY AS A LINK. TO USE C THIS ENTRY FROM THE DIRECTORY, MUST ELIMINATE PREVIOUS C ENTRY BY MOVING ELEMENTS UP AND INSERTING STATION K C AT ITS RIGHTFUL PLACE J. OTHERWISE, THE STATIONS MAY C NOT BE ALPHABETICAL BY ICAO DIRECTORY ENTRY. C IF(LINKNO(K).LT.L)GO TO 139 C IF THE LINK FOR STATION K IS CLOSER TO THE LEFT IN THE C DIRECTORY THAN THE COLUMN L BEING PROCESSED, NO C ENTRY FOR THIS STATION IS REQUIRED. IT IS ALREADY IN C THE LIST AND IS DUE TO A LINK CLOSER TO THE LEFT IN C THE DIRECTORY. C LINKK=LINK(K)+1 C C LINKS FOR STATIONS GT K IN THE LIST NEED TO BE DECREASED C BY 1 TO ACCOUNT FOR THE DELETION BELOW. C DO 1388 M=LINKK,NSTA C IF(LINK(M).NE.0)THEN C IF(LINK(M).GT.LINK(K))THEN LINK(M)=LINK(M)-1 ENDIF C ENDIF C 1388 CONTINUE C DO 1315 M=LINKK,JSTA C IN CASE LINKK GT JSTA, THIS LOOP WILL NOT BE EXECUTED. CCALL(M-1,1)=CCALL(M,1) CCALL(M-1,2)=CCALL(M,2) CCALL(M-1,3)=CCALL(M,3) CCALL(M-1,4)=CCALL(M,4) CCALL(M-1,5)=CCALL(M,5) CCALL(M-1,6)=CCALL(M,6) NAME(M-1)(1:17)=NAME(M)(1:17) NAME(M-1)(19:20)=NAME(M)(19:20) IBLOCK(M-1)=IBLOCK(M) IWBAN(M-1)=IWBAN(M) ELEV(M-1)=ELEV(M) ITIMEZ(M-1)=ITIMEZ(M) ITYPE(M-1)=ITYPE(M) STALAT(M-1)=STALAT(M) STALON(M-1)=STALON(M) 1315 CONTINUE C ELSE J=JSTA+1 JSTA=J ENDIF C JP1=JP1+1 IF(J.LE.ND1)GO TO 135 C ND1 ABOUT TO BE EXCEEDED. THIS IS A SAFETY FEATURE AND C SHOULD NOT OCCUR. C WRITE(KFILDO,132)ND1 IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,132)ND1 IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5)WRITE(IP5,132)ND1 132 FORMAT(/' ****TOO MANY STATIONS IN LIST FOR DIMENSION ND1 =', 1 I7,'.') IER=34 J=J-1 NSTA=J GO TO 148 C 135 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)(1:17)=NAMET(1:17) NAME(J)(19:20)=NAMET(19:20) IBLOCK(J)=NBLOCK IWBAN(J)=IWBANT ELEV(J)=ELEVT ITIMEZ(J)=ITIMEX ITYPE(J)=ITYPEX 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. NSTX=J LOC(K)=J C C SET LINKNO(K) TO THE COLUMN IN THE DIRECTORY BEING C PROCESSED. C LINKNO(K)=L 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 IF(L.EQ.1)THEN LINK(K)=0 ELSE LINK(K)=J ENDIF C 139 CONTINUE C 1395 CONTINUE C GO TO 121 C C STATIONS IN THE LIST THAT HAVE NOT BEEN ENTERED C INTO CCALLD( ) LIST (BECAUSE THEY WERE NOT IN THE C DIRECTORY) MUST BE ADDED TO CCALLD( ). C 140 JER=0 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)CCALLD(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,141)CCALLD(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,141)CCALLD(K) 141 FORMAT(/,' ****STATION ',A8,' NOT FOUND IN DIRECTORY') ELSE WRITE(KFILDO,1410)CCALLD(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1410)CCALLD(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1410)CCALLD(K) 1410 FORMAT(' ****STATION ',A8,' NOT FOUND IN DIRECTORY') ENDIF C JER=1 NSTX=NSTX+1 IF(NSTX.LE.ND1)GO TO 1412 C ND1 ABOUT TO BE EXCEEDED. THIS IS A SAFETY FEATURE AND C SHOULD NOT OCCUR. C WRITE(KFILDO,132)ND1 IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,132)ND1 IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5)WRITE(IP5,132)ND1 IER=34 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( , ). GO TO 145 C 1412 CCALL(NSTX,1)=CCALLD(K) C ELSEIF(IFOUND(K).EQ.7)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,142)CCALL(LOC(K),1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,142)CCALL(LOC(K),1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,142)CCALL(LOC(K),1) 142 FORMAT(/' ****STATION ',A8,' IS A DUPLICATE.') ELSE WRITE(KFILDO,1420)CCALL(LOC(K),1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1420)CCALL(LOC(K),1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1420)CCALL(LOC(K),1) 1420 FORMAT(' ****STATION ',A8,' IS A DUPLICATE.') ENDIF C JER=1 ELSEIF(IFOUND(K).EQ.8)THEN C IF(JER.EQ.0)THEN WRITE(KFILDO,143)CCALL(LOC(K),1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,143)CCALL(LOC(K),1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,143)CCALL(LOC(K),1) 143 FORMAT(/' ****STATION ',A8,' IS A DUPLICATE', 1 ' MAY BE CAUSED BY A LINK TO ALTERNATE STATION.') ELSE WRITE(KFILDO,1430)CCALL(LOC(K),1) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1430)CCALL(LOC(K),1) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1430)CCALL(LOC(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(LOC(K),1),IFOUND(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,144) 1 CCALL(LOC(K),1),IFOUND(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,144)CCALL(LOC(K),1),IFOUND(K) 144 FORMAT(/' ****STATION ',A8,' REQUIRED A LINK NO. =',I3,'.') ELSE WRITE(KFILDO,1440)CCALL(LOC(K),1),IFOUND(K) IF(IP4.NE.0.AND.IP4.NE.KFILDO)WRITE(IP4,1440) 1 CCALL(LOC(K),1),IFOUND(K) IF(IP5.NE.0.AND.IP5.NE.KFILDO.AND.IP4.NE.IP5) 1 WRITE(IP5,1440)CCALL(LOC(K),1),IFOUND(K) 1440 FORMAT(' ****STATION ',A8,' REQUIRED A LINK NO. =',I3,'.') ENDIF C JER=1 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 INFORMATION 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 RDSTQT ') C 160 RETURN END