SUBROUTINE RDPRS(KFILDO,KFILLP,IP8,ICALL,CCALL,NAME,NSTA, 1 NOPAR,LOCPAR,ND1, 2 IALOC,ADIST,AELEV,ND13,ICALLD,CCALLD,ND5,L3264W, 3 ISTOP,IER) C C MAY 2005 GLAHN MDL MOS-2000 C MAY 2005 GLAHN MAJOR REVISION C SEPTEMBER 2005 GLAHN CHANGED 2 FORMATS PER TRIMARCO C OCTOBER 2005 GLAHN ACCOMMODATED KFILLP = 0 C MARCH 2006 GLAHN SET IER = 0 UPON ENTRY C DECEMBER 2006 GLAHN COMMENT CHANGE C DECEMBER 2007 GLAHN CHANGED L+1 TO LSTA+1 BELOW THE C DO 120 LOOP PLUS CHECK ON ND5 C DECEMBER 2008 GLAHN INSERTED **** IN FRONT OF SOME C FATAL DIAGNOSTICS; ADDED FORMAT 103 C SEPTEMBER 2012 ENGLE CHANGED READING OF STATION CALL C LETTERS INTO CCALLD, INSTEAD OF ICALLD C C PURPOSE C RDPRS READS THE LIST OF PAIRS OF STATIONS FOR EACH STATION C TO USE IN LAPSE RATE COMPUTATIONS AND KEYS THE LIST READ C TO THE LIST USED IN THIS ANALYSIS RUN. C C DATA SET USE C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFILLP - UNIT NUMBER WHERE PAIRS RESIDE. (INPUT) C IP(J) - UNIT NUMBERS FOR OPTIONAL OUTPUT (J=1,25) C (SEE IP( ) UNDER "VARIABLES" BELOW.) (OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFILLP = UNIT NUMBER WHERE PAIRS RESIDE. WHEN = 0, C THERE IS NO PAIRS LIST. (INPUT) C IP8 = THE STATIONS AND THEIR PAIRS AS READ ARE C WRITTEN TO IP8 IF NOT ZERO. (OUTPUT) C ICALL(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,NSTA). C NOTE THAT THIS REQUIRES TWO 32-BIT C WORDS TO HOLD THE DESCRIPTION BUT ONLY ONE C 64-BIT WORD. EQUIVALENCED TO CCALL( ). C CCALL(K) = 8-CHARACTER STATION CALL LETTERS (K=1,NSTA). C NOTE THAT THE SUBSTITUTE STATIONS IN CCALL( , ) C IN THE CALLING PROGRAM ARE NOT USED. C (CHARACTER*8) (INPUT) C NAME(K) = NAMES OF STATIONS (K=1,NSTA). (CHARACTER*20) C NSTA = THE NUMBER OF STATIONS BEING DEALT WITH. THE C NUMBER OF VALUES IN CCALL( , ), ETC. (INPUT) C NOPAR(K) = NUMBER OF PAIRS FOR STATION K (K=1,NSTA). C (OUTPUT) C LOCPAR(K) = WHERE IN IALOC( ), ADIST( ), AND AELEV( ) THE C DATA FOR STATION CCALL(K) STARTS (K=1,LSTA). C THERE IS ALWAYS ONE LOCATION EVEN FOR A STATION C WITH NO LIST, IN WHICH CASE LOCPAR(K) = 9999. C (OUTPUT) C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT C WITH. SIZE OF ARRAYS LOCPAR( ), NOPAR( ), C AND CCALL( ) AND SECOND DIMENSION OF ICALL( , ). C (INPUT) C IALOC(J) = THE LOCATIONS OF THE PAIRS FOR EACH STATION C K IN THE NSTA LIST, NOPAR(K) VALUES FOR EACH C STATION K. (J=1,ND13). (OUTPUT) C ADIST(J) = DISTANCES OF BASE STATION TO THE PAIRED STATIONS C (J=1,ND13), NOPAR(K) VALUES FOR EACH STATION K. C (OUTPUT) C AELEV(J) = ELEVATION DIFFERENCES IN M OF BASE STATION TO C THE PAIRED STATIONS (J=1,ND13), NOPAR(K) VALUES C FOR EACH STATION K. (OUTPUT) C ND13 = SIZE OF ARRAYS IALOC( ), ADIST( ), AND AELEV( ). C (INPUT) C ICALLD(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN C INTEGER VARIABLE (L=1,L3264W) (K=1,LSTA). C NOTE THAT THIS REQUIRES TWO 32-BIT C WORDS TO HOLD THE DESCRIPTION BUT ONLY ONE C 64-BIT WORD. EQUIVALENCED TO CCALLD( ). C (INTERNAL) C CCALLD(K) = 8-CHARACTER STATION CALL LETTERS (K=1,LSTA). C NOTE THAT THE SUBSTITUTE STATIONS ARE NOT USED. C EQUIVALNECED TO ICALLD( , ). (CHARACTER*8) C (INTERNAL) C ND5 = SECOND DIMENSION OF ICALLD( , ) AND DIMENSION C OF CCALLD( ). (INPUT) C (INPUT) C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2). C (INPUT) C ISTOP = 0 MEANS THE PROGRAM IS RUNNING OK UP TO THIS C POINT. WHENEVER AN ERROR OCCURS THAT SHOULD C HALT THE PROGRAM AFTER INPUT DIAGNOSTICS ARE C PRINTED, ISTOP IS SET = ISTOP+1. (INPUT-OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 777 = FATAL ERROR. C (OUTPUT) C LSTA = THE NUMBER OF STATIONS WITH PAIRS READ IN. C (INTERNAL) C MSTA = THE NUMBER OF VALUES IN THE IALOC( ), ADIST( ), C AND AELEV( ) ARRAYS. (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C NONE C CHARACTER*4 STATE CHARACTER*8 CCALL(ND1) CHARACTER*8 CCALLD(ND5) CHARACTER*20 NAME(ND1) C DIMENSION ICALL(L3264W,ND1) DIMENSION LOCPAR(ND1),NOPAR(ND1) DIMENSION ICALLD(L3264W,ND5) DIMENSION IALOC(ND13),ADIST(ND13),AELEV(ND13) C C READ THE FIRST RECORD. THIS IS THE NUMBER OF STATIONS C THAT HAVE PAIRS. C IER=0 C IF(KFILLP.EQ.0)THEN C C THERE IS NO PAIRS LIST. C GO TO 160 ENDIF C CD WRITE(KFILDO,103)KFILLP,IP8,NSTA CD103 FORMAT(/' AT 103 IN RDPRS--KFILLP,IP8,NSTA',3I10) C IF(IP8.NE.0)THEN WRITE(IP8,105) 105 FORMAT(/,' **********OUTPUT FROM RDPRS**********') ENDIF C STATE=' 108' READ(KFILLP,IOSTAT=IOS,ERR=900,END=900)LSTA WRITE(KFILDO,108)LSTA,KFILLP 108 FORMAT(/,' ',I6,' STATIONS FOR WHICH PAIRS ARE ON INPUT FILE,', 1 ' UNIT NUMBER',I4) C C MAKE SURE THERE IS ROOM IN ARRAYS FOR LSTA STATIONS. C IF(LSTA.GT.ND1)THEN WRITE(KFILDO,110)LSTA,ND1 110 FORMAT(/,' ****NUMBER OF STATIONS =',I6,' FOR WHICH PAIRS', 1 ' ARE TO BE READ EXCEEDS ND1 =',I6,'. FATAL', 2 ' ERROR IN RDPRS.') IER=777 GO TO 160 ENDIF C C READ LSTA RECORDS IN PAIRS. THE FIRST OF THE PAIR HOLDS C CALL LETTERS OF THE STATION THAT HAS PAIRS [CCALLD( )] C AND THE NUMBER OF PAIRS FOR THAT STATION [NOPAR( )]. C C THE SECOND OF THE PAIR HOLDS (1) THE LOCATION OF EACH STATION C OF THE PAIR IN THE CCALLD( ) LIST, (2) THE HORIZONTAL DISTANCE C ADIST( ), AND (3) THE VERTICAL DISTANCE AELEV( ) FROM THE C STATION IN CCALLD( ) TO ITS PAIR. ADIST( ) IS IN GRID UNITS C AND AELEV IS THE VALUE IN METERS. NOTE THAT C U174 HAS TO BE RUN WITH THE SAME GRID SPACING AS U155. C MSTA=0 C DO 120 L=1,LSTA LOCPAR(L)=MSTA+1 C LOCPAR(L) IS WHERE THE DATA FOR STATION CCALLD(L) STARTS IN C THE LINEAR ARRAYS IALOC( ), ADIST( ), AND AELEV( ) ACCORDING C TO THE LIST IN CCALLD( ). STATE=' 111' CINTEL C READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) C 1 (ICALLD(J,L),J=1,L3264W),NOPAR(L) READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) 1 CCALLD(L),NOPAR(L) CINTEL C CD WRITE(KFILDO,1105)CCALLD(L),NOPAR(L) CD1105 FORMAT(/,' AT 1105 IN RDPRS--CCALLD(L),NOPAR(L)', CD 1 2X,A8,I8) C IF(CCALLD(L).EQ.'999999 ')THEN WRITE(KFILDO,112)L-1 112 FORMAT(/,' ****TERMINATOR ENCOUNTERED BEFORE LSTA STATIONS', 1 ' READ IN RDPRS. STATIONS READ =',I6, 2 '. COUNT AS FATAL.') ISTOP=ISTOP+1 IER=777 GO TO 160 ENDIF C IF(NOPAR(L).EQ.9999)THEN C C THIS STATION HAS NO PAIRS LIST. C IF(MSTA+1.LE.ND13)THEN STATE=' 113' READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) 1 (IALOC(J),ADIST(J),AELEV(J), 2 J=LOCPAR(L),LOCPAR(L)) MSTA=MSTA+1 C ONE POSITION IS OCCUPIED IN LISTS FOR A STATION C WITH NO PAIRS. ELSE WRITE(KFILDO,114)ND13 114 FORMAT(/,' ****ND13 =',I8,' IS NOT LARGE ENOUGH IN RDPRS.', 1 ' FATAL ERROR.') IER=777 ISTOP=ISTOP+1 GO TO 160 ENDIF C ELSE C C THIS STATION HAS A PAIRS LIST. C CD WRITE(KFILDO,1140)L,CCALLD(L),LOCPAR(L),NOPAR(L),ND13 CD1140 FORMAT(' AT 1140--L,CCALLD(L),LOCPAR(L),NOPAR(L),ND13', CD 1 I10,2X,A8,3I10) IF(MSTA+NOPAR(L).LE.ND13)THEN STATE=' 114' READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) 1 (IALOC(J),ADIST(J),AELEV(J), 2 J=LOCPAR(L),LOCPAR(L)+NOPAR(L)-1) CD WRITE(KFILDO,1141)IALOC(LOCPAR(L)), CD 1 IALOC(LOCPAR(L)+NOPAR(L)-1) CD1141 FORMAT(' FIRST AND LAST VALUES OF IALOC( ) READ', CD 1 2I8) MSTA=MSTA+NOPAR(L) ELSE WRITE(KFILDO,114)ND13 IER=777 ISTOP=ISTOP+1 GO TO 160 ENDIF C ENDIF C IF(IP8.NE.0)THEN C IF(NOPAR(L).EQ.9999)THEN WRITE(IP8,115)CCALLD(L) 115 FORMAT(/,' STATION ',A8,' HAS NO PAIRS.') ELSE WRITE(IP8,116)CCALLD(L),NOPAR(L), 1 (IALOC(J),ADIST(J),AELEV(J), 2 J=MSTA-NOPAR(L)+1,MSTA) 116 FORMAT(/,' STATION ',A8,' HAS',I6,' PAIRS,', 1 ' LOCATION IN LIST, ADIST, AELEV',/, 2 (2X,4(I8,2F10.2))) ENDIF C ENDIF C 120 CONTINUE C C READ THE TERMINATOR. C IF(LSTA+1.LE.ND5)THEN STATE=' 125' CINTEL C READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) C 1 (ICALLD(J,LSTA+1),J=1,L3264W) READ(KFILLP,IOSTAT=IOS,ERR=900,END=900) 1 CCALLD(LSTA+1) CINTEL CD WRITE(KFILDO,125)CCALLD(LSTA+1) CD125 FORMAT(/' AT 125 IN RDPRS--CCALLD(LSTA+1)',2X,A8) C IF(CCALLD(LSTA+1).NE.'999999 ')THEN WRITE(KFILDO,127)LSTA 127 FORMAT(/,' ****TERMINATOR NOT FOUND AT END OF LSTA =',I6, 1 ' STATIONS IN RDPRS. COUNT AS FATAL.') ISTOP=ISTOP+1 IER=777 GO TO 160 ELSE WRITE(KFILDO,129)LSTA,MSTA 129 FORMAT(/,' DATA READ SUCCESSFULLY IN RDPRS FOR LSTA =',I6, 1 ' STATIONS. ARRAYS IALOC( ), ADIST( ), AND', 2 ' AELEV( ) EACH HAVE ',I10,' ENTIRES.') ENDIF C ELSE WRITE(KFILDO,130)ND5 130 FORMAT(/,' ****NO ROOM IN ICALLD( , ) TO READ TERMINATOR.', 1 ' COUNT THIS AS A FATAL ERROR. INCREASE ND5 = ', 2 I6,' BY 1') ISTOP=ISTOP+1 IER=777 GO TO 160 ENDIF C C CHANGE THE LINKS IN IALOC( ) FROM REFERENCE TO THE LSTA C INPUT LIST TO THE NSTA ANALYSIS LIST. ALSO ORDER C NOPAR( ) AND LOCPAR( ) ACCORDING TO THE NSTA LIST C RATHER THAN THE LSTA LIST. C CALL KEYLST(KFILDO,IP8,CCALL,CCALLD,IALOC, 1 NOPAR,LOCPAR,NSTA,LSTA,MSTA,ISTOP,IER) C 160 RETURN C C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT. C 900 CALL IERX(KFILDO,KFILDO,IOS,'RDPRS',STATE) WRITE(KFILDO,901) 901 FORMAT(' FATAL SYSTEM ROUTINE ERROR IN RDPRS.') ISTOP=ISTOP+1 IER=777 GO TO 160 END