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