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