SUBROUTINE RDSTAL2(KFILDO,IP4,IP5,KFILD,NEW,CCALL,
1 NAME,NELEV,IWBAN,STALAT,STALON,ITIMEZ,IFOUND,
2 ND1,NSTA,IER)
C
C SEPTEMBER 2018 SHAFER MODIFIED VERSION OF RDSTAL TO BYPASS
C STATION CHECKING. ROUTINE EXITS AFTER
C STATION DIRECTORY IS READ IN.
C
C
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 RDSTAL AND RDSTAD IS
C THAT RDSTAD ALPHABETIZES STATIONS, WHILE RDSTAL
C DOES NOT. RDSTAL IS USED FOR A SINGLE STATION
C LIST PER CALL; RDSTGN IS USED FOR MULTIPLE LISTS.
C
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 NELEV(K) = ELEVATION OF STATIONS (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 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( , ), NELEV( ), 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 NELEVT = 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 NELEV(ND1),IWBAN(ND1),ITIMEZ(ND1),
1 STALAT(ND1),STALON(ND1),IFOUND(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 RDSTAL ')
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
NELEV(K)=0
IWBAN(K)=0
STALAT(K)=0.
STALON(K)=0.
ITIMEZ(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
C MODIFIED JUN 2017
C
C WHEN DEALING WITH A LARGE STATION LIST (SUCH AS GRIDPOINTS AS
C STATIONS FROM A HIGH RES GRID) DO NOT PRINT THE STATION LIST
C BELOW. THRESHOLD OF 50K STATIONS IS TO ACCOMMODATE GLAMP.
C
IF(IER.NE.0)THEN
IF (NSTA.LT.50000) THEN
WRITE(KFILDO,110)NSTA,(CCALL(K,1),K=1,NSTA)
110 FORMAT(/,' ',I8,' STATIONS INPUT, PRINTED BELOW.',
1 /,(14(1X,A8)))
ELSE
WRITE(KFILDO,1100) NSTA
1100 FORMAT(/,' ',I8,' STATIONS INPUT, WHICH WILL NOT BE',
1 ' PRINTED TO MAKE THIS FORT EASIER TO READ. ',
2 ' SET IP(4) TO PRINT STATIONS IF NECESSARY.')
END IF
C
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 NELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEX,ITYPE,
3 OPEN,(CCALLT(K),K=3,6),IDATE,IWBANT
122 FORMAT(A8,1X,A8,1X,A17,4X,A2,1X,I6,1X,I5,1X,A1,F7.4,1X,A1,F8.4,
1 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 NELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEX,ITYPE,
3 OPEN,(CCALLT(K),K=3,6),IDATE,IWBANT
ENDIF
C
C 9/11/18: EXIT ROUTINE AFTER READING IN DIRECTORY.
C NO NEED TO PERFORM STATION CHECKS.
C
C GO TO 130
GO TO 160
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 RDSTAL.',
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
IWBAN(J)=IWBANT
ITIMEZ(J)=ITIMEX
NELEV(J)=NELEVT
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 NELEV( ), 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
IWBAN(K)=IWBANT
ITIMEZ(K)=ITIMEX
NELEV(K)=NELEVT
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
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),STALAT(J),STALON(J),NELEV(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),STALAT(J),STALON(J),NELEV(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 ' LAT LON ELEV ZONE SUBSTITUTE STATIONS'/
3 (1X,I6,2X,A8,1X,A20,1X,I5,2F8.2,I6,I5,2X,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),STALAT(J),STALON(J),NELEV(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),STALAT(J),STALON(J),NELEV(J),ITIMEZ(J),
3 (CCALL(J,I),I=2,6),J=1,NSTA)
ENDIF
C
ENDIF
C
D CALL TIMPR(KFILDO,KFILDO,'END RDSTAL ')
C
160 RETURN
END