SUBROUTINE RDSTGRID(KFILDO,IP7,IP8,KFILD,NEW,CCALL,CCALLD,
1 NAME,NELEV,IWBAN,STALAT,STALON,IFOUND,ISTA,
2 ND1,IER)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK ***
C
C SUBPROGRAM: U140
C PRGMMR: WEISS ORG: W/OST22 DATE: 2005-01-01
C
C ABSTRACT: TO READ A STATION LIST OF GRID POINTS AND ASSOCIATED
C INFORMATION FROM A STATION DIRECTORY.
C THE STATION LIST IS PUT INTO CCALL( ,1), WITH UP TO
C 5 SUBSTITUTE STATIONS, THOUGH ONLY CCALL(1, ) IS
C USED FOR REFERENCING (THE "PRIMARY" VALUE).
C THE LIST (8 CALL LETTERS)
C THE CALL TO RDC IS SET TO READ UP TO NT = 7
C VALUES PER RECORD ACCORDING TO THE FORMAT (7(A8,1X));
C HOWEVER, THE RECORD NEED NOT HAVE THAT MANY VALUES.
C STATION IDENTIFIERS SUCH AS STATION LATITUDE, LONGITUDE,
C ELEVATION, AND NAME, ARE RETURNED.
C
C NOTE: THIS RDC PORTION OF THE CODE IS INACTIVE FOR THE
C PRESENT TIME.
C
C NOTE: THE DIFFERENCE BETWEEN THIS RDSTGRID AND RDSTGN IS
C THAT RDSTGRID ALPHABETIZES STATIONS, WHILE RDSTGN
C DOES NOT. RDSTAD IS USED FOR A SINGLE STATION
C LIST; RDSTGRID IS USED FOR MULTIPLE LISTS.
C
C PROGRAM HISTORY LOG:
C 05-01-01 WEISS
C 05-03-07 MALONEY ADDED NCEP DOCBLOCK
C
C USAGE: CALLED BY INT140
C
C DATA SET USE
C INPUT FILES:
C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT)
C FORT.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 OUTPUT FILES:
C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT)
C FORT.IP7 - UNIT NUMBER FOR OUTPUT OF CALL LETTERS (OUTPUT)
C FORT.IP8 - UNIT NUMBER FOR OUTPUT OF DIRECTORY INFORMATION
C (OUTPUT)
C
C VARIABLES
C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE.
C (INPUT)
C IP7 = INDICATES WHETHER (>0) OR NOT (=0) THE STATION
C LIST (CALL LETTERS ONLY) WILL BE WRITTEN TO UNIT
C IP7. 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 IP7. (INPUT)
C IP8 = INDICATES WHETHER (>0) OR NOT (=0) THE STATION
C DIRECTORY INFORMATION WILL BE WRITTEN TO UNIT
C IP8. 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 IP8. (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,ND1).
C (CHARACTER*8) (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,ND1) (CHARACTER*20)
C (OUTPUT)
C NELEV(K) = ELEVATION OF STATIONS (K=1,ND1). (OUTPUT)
C STALAT(K) = LATITUDE OF STATIONS (K=1,ND1). (OUTPUT)
C STALON(K) = LONGITUDE OF STATIONS (K=1,ND1). (OUTPUT)
C IWBAN(K) = WBAN NUMBERS OF STATIONS (K=1,ND1). (OUTPUT)
C IFOUND(K) = USED TO KEEP TRACK OF THE STATIONS FOUND IN THE
C DIRECTORY (K=1,ND1).
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 ISTA = THE NUMBER OF COUNTED STATIONS IN THE STATION
C TABLE (OUTPUT).
C ND1 = SIZE OF ARRAYS CCALL( , ), CCALLD( ), NAME( ),
C NELEV( ), IWBAN( ), STALAT( ), STALON( )
C IFOUND( ). THIS IS
C THE MAXIMUM NUMBER OF STATIONS IN THE LIST TO
C BE RETURNED. (INPUT)
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 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
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 NELEVT = TO READ ELEVATION INTO FROM DIRECTORY.
C (INTERNAL)
C IWBANT = TO READ WBAN NUMBER 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 = INTERNAL COUNTER. (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,ND1). (AUTOMATIC) (INTERNAL)
C LINKNO(K) = USED FOR KEEPING TRACK OF THE LINK NUMBER
C FOR EACH STATION (K=1,ND1) (AUTOMATIC)
C (INTERNAL)
C LOC(K) = LOCATION IN LIST CCALL( , ) WHERE STATION K
C WENT. (AUTOMATIC) (INTERNAL)
C
C SUBPROGRAMS CALLED:
C UNIQUE - NONE
C LIBRARY:
C MOSLIB - RDC
C
C EXIT STATES:
C COND = 0 - SUCCESSFUL RUN
C OTHER VALUES RETURNED FROM SUBROUTINES.
C
C REMARKS: NONE
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90 (xlf90 compiler)
C MACHINE: IBM SP
C
C$$$
C
IMPLICIT NONE
INTEGER, PARAMETER :: NT=7
C
C
CHARACTER*1 SIGNLA,SIGNLO,OPEN
CHARACTER*8 CCALL(ND1,6),CCALLD(ND1),CTEMP(NT),BLANK8,
1 CCALLT(6),CCALL_TEST
CHARACTER*20 NAME(ND1),NAMET,BLANK
C
INTEGER NELEV(ND1),IWBAN(ND1),IFOUND(ND1),
1 LINK(ND1),LINKNO(ND1),LOC(ND1)
INTEGER KFILDO,KFILD(2),IER,ISTART,ISTA,ND1,IP7,IP8,
1 NEW,K,J,IOS,NSTA1
INTEGER NELEVT,NBLOCK,ITIMEZ,ITYPE,IDATE,IWBANT
REAL STALAT(ND1),STALON(ND1),XLATDD,XLONDD
C
CC DIMENSION NELEV(ND1),IWBAN(ND1),STALAT(ND1),STALON(ND1),
CC 1 IFOUND(ND1)
CC DIMENSION LINK(ND1),LINKNO(ND1),LOC(ND1)
CC DIMENSION KFILD(2)
C
C
C LINK( ), LINKNO( ), LOC( ) ARE
C AUTOMATIC ARRAYS.
C
C
DATA BLANK8/' '/
DATA BLANK/' '/
DATA CCALLT/6*' '/
DATA NAMET/' '/
C
D CALL TIMPR(KFILDO,KFILDO,'START RDSTGRID ')
C
IER=0
ISTART=0
ISTA=0
C
C INITIALIZE ARRAYS.
C
DO 103 K=1,ND1
C
DO 102 J=1,6
CCALL(K,J)=BLANK8
102 CONTINUE
C
NELEV(K)=0
IWBAN(K)=0
STALAT(K)=0.
STALON(K)=0.
IFOUND(K)=0
LINK(K)=0
LINKNO(K)=0
LOC(K)=0
NAME(K)=BLANK
103 CONTINUE
C
C KFILD(1) CANNOT EQUAL KFILD(2).
C
IF(KFILD(1).EQ.KFILD(2))THEN
WRITE(KFILDO,104)KFILD(1)
104 FORMAT(/,' ****KFILD(1) AND KFILD(2) ARE BOTH =',I3,
1 '. CHANGE ONE OR THE OTHER.')
ENDIF
C
C READ STATION LIST FROM UNIT NUMBER KFILD(1).
CCCC
CCCC TEST READ FOR SELECTED GRID POINTS, THE GRID POINTS
CCCC ARE NOT USED FOR ANYTHING IN THE CODE
CCCC
C
105 CALL RDC(KFILDO,IP7,KFILD(1),CCALLD(ISTART+1),ND1-ISTART,CTEMP,NT,
1 '(7(A8,1X))',NSTA1,'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 IER FROM RDC WILL BE OVERWRITTEN IF THERE ARE DUPLICATE
C STATIONS IN THE LIST, OR IF A STATION CANNOT BE FOUND
C IN THE DIRECTORY. WHEN IER NE 0, A DIAGNOSTIC WILL
C HAVE BEEN WRITTEN BY RDC.
C
IF(IER.NE.0.AND.NSTA1.NE.0)THEN
WRITE(KFILDO,110)NSTA1,(CCALLD(K),K=ISTART+1,ISTART+NSTA1)
110 FORMAT(/,' ',I10,' STATIONS INPUT:',1X,
1 10(1X,A8),/,(14X,13(1X,A8)))
ENDIF
C
IF(NSTA1.EQ.0)GO TO 120
C AN EMPTY SET TERMINATES READING.
IF(IP7.EQ.0)GO TO 115
IF(IP7.EQ.KFILDO.AND.IER.NE.0.AND.NSTA1.NE.0)GO TO 115
C
C STATION LIST MAY BE WRITTEN TWICE WHEN THERE ARE ERRORS
C DETECTED, ONCE TO THE DEFAULT OUTPUT FILE AND ONCE TO UNIT
C IP7.
C
WRITE(IP7,110)NSTA1,(CCALLD(K),K=ISTART+1,ISTART+NSTA1)
C
C
115 CONTINUE
C
C
120 CONTINUE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C********************************************************************C
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
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=1405)CCALLT(1),
1 CCALLT(2),NAMET(1:17),NAMET(19:20),NBLOCK,
2 NELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEZ,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=1405)CCALLT(2),
1 CCALLT(1),NAMET(1:17),NAMET(19:20),NBLOCK,
2 NELEVT,SIGNLA,XLATDD,SIGNLO,XLONDD,ITIMEZ,ITYPE,
3 OPEN,(CCALLT(K),K=3,6),IDATE,IWBANT
ENDIF
C
C COUNTING THE NUMBER OF CALL LETTERS READ FROM THE
C STATION TABLE
ISTA=ISTA+1
C
GO TO 130
C
C ERROR READING DIRECTORY.
C
123 WRITE(KFILDO,124)IOS
IF(IP7.NE.0.AND.IP7.NE.KFILDO)WRITE(IP7,124)IOS
IF(IP8.NE.0.AND.IP8.NE.KFILDO.AND.IP7.NE.IP8)WRITE(IP8,124)IOS
124 FORMAT(/,' ****ERROR READING STATION DIRECTORY IN RDSTGRID.',
1 ' IOSTAT =',I5)
IER=33
GO TO 1405
130 CONTINUE
C
if(ISTA.LE.ND1)THEN
CCC IFOUND(ISTA)=1
CCALL(ISTA,1)=CCALLT(1)
NAME(ISTA)(1:17)=NAMET(1:17)
NAME(ISTA)(19:20)=NAMET(19:20)
IWBAN(ISTA)=IWBANT
NELEV(ISTA)=NELEVT
STALAT(ISTA)=XLATDD
IF(SIGNLA.EQ.'S')STALAT(ISTA)=-STALAT(ISTA)
C ABOVE STATEMENT MAKES SOUTH LATITUDE NEGATIVE.
STALON(ISTA)=XLONDD
IF(SIGNLO.EQ.'E')STALON(ISTA)=360.-STALON(ISTA)
C ABOVE STATEMENT MAKES ALL LONGITUDES WEST, RANGE 0-360.
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
C
GO TO 121
C
CC
1405 IF(ISTA.GT.ND1)THEN
WRITE(KFILDO,138)ND1
138 FORMAT(/,' ****TOO MANY GRID POINTS IN RDSTGRID FOR',
1 ' DIMENSION ND1 =',I4)
IER=34
ENDIF
CC
C
C
C NOTE: THERE IS NO TEST FOR DUPLICATES
C (ONLY TEST FOR CALL LETTER IN FIRST COLUMN)
C "NO LINKS"
C ARRAY IFOUND IS THEREFORE NOT USED
C
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 160
C
C ADJUST IER AS NECESSARY.
CCC IER = 35 - ONE OR MORE STATIONS NOT FOUND.
CcC = 36 - LINK USED FOR ONE OR MORE STATIONS.
CCC = 37 - BOTH OF ABOVE.
C
C
D CALL TIMPR(KFILDO,KFILDO,'END RDSTGRID ')
C
160 RETURN
END