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