CTITLESAGWDC -- READS AND PROCESS WATER DEPTHS FOR GM3D 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR J. MENDEKE 00000201 CA DESIGNER J. MENDEKE 00000301 CA LANGUAGE FORTRAN 00000401 CA SYSTEM IBM AND CRAY 00000501 CA WRITTEN 03-23-78 00000601 C REVISED 09/25/78 MENDEKE - SET RLOCNO TO FLOAT PT. 00000701 C REVISED 03/17/83 PARKER - ADDED CHECKS FOR REQUIRED DF6 AND 00000801 C DF8 AND DELETED REFERENCE TO DF7 00000901 C REVISED 11-02-83 CROWLEY - CORRECTED ABANDON FLAG 00001001 C IN CALLING SEQUENCE. 00001101 C REVISED 06/06/84 PONTON - REWROTE ENTIRE SECTION 00001201 C OF CODE THAT PERFORMS WATER 00001300 C DEPTH INTERPOLATION. 00001400 C REVISED 08/06/84 KNIGHT - DIMENSION TRCHDR TO 190. 00001501 C REVISED 03/01/85 KNIGHT - DUAL IBM/CRAY VERSION. 00001601 C REVISED 02/06/89 TRULOCK- ALLOW MULTIPLE ALP CARDS. 00001701 C REVISED 03/20/89 TRULOCK- SINGLE SOURCE CODE FOR IBM AND CRAY00001801 C REVISED 05/05/89 COMPTON- FIX INDEX FOR DWATER. 00001901 C REVISED 11/13/89 KNIGHT - FOR CRAY CFT77 COMPATIBILITY. 00002002 CA 00002100 CA 00002200 CA CALL SAGWDC 00002300 CA (KPNA,KPRNO,ASPNO,SPLSNO,DWATER,WORK, 00002401 CA INDEX,NOREC,LCTPSP,LRTF,NOERR,IPR) 00002501 CA INPUT KPNA = PROCESS NAME A4 00002600 CA INPUT KPRNO = PROCESS NUMBER I4 00002700 CA INPUT ASPNO = SHOTPOINT NO. ARRAY I4 00002800 CA INPUT SPLSNO = SHOTPOINT LINE STATIONS R4 00002900 CA INPUT DWATER = WATER DEPTH ARRAY I4 00003000 CA INPUT WORK = WORK ARRAY I4 00003100 CA INPUT INDEX = NO. OF ELEMENTS IN ASPNO I4 00003200 CA INPUT NOREC = NO. OF HEADERS IN GM3D FILE I4 00003300 CA INPUT LCTPSP = TRACES PER SHOTPOINT I4 00003400 CA INPUT LRFT = ERROR RETURN FLAG (= -1) IF ERROR I4 00003500 CA INPUT NOERR = ERROR COUNTER I4 00003600 CA INPUT IPR = PRINTER UNIT I4 00003700 CA 00003800 CA THIS SUBROUTINE STORES WATER DEPTHS IN THE GM3D 00003900 CA TRACE HEADERS. 00004000 C 00004100 SUBROUTINE SAGWDC 00004200 * (KPNA,KPRNO,ASPNO,SPLSNO,DWATER,WORK, 00004300 * INDEX,NOREC,LCTPSP,LRTF,NOERR,IPR) 00004400 C 00004500 IMPLICIT INTEGER (A-Z) 00004600 C 00004700 C INTEGER ARRAYS IN PARAMETER LIST 00004800 C 00004900 INTEGER ASPNO (1) 00005000 INTEGER DWATER (1) 00005100 INTEGER WORK (1) 00005200 C 00005300 C REAL ARRAYS IN PARAMETER LIST 00005400 C 00005500 REAL SPLSNO (1) 00005600 C 00005700 C INTEGER ARRAYS - LOCAL 00005800 C 00005900 INTEGER TRCHDR (190) 00006000 C 00006100 C REAL VARIABLES - LOCAL 00006200 C 00006300 REAL DIFF 00006400 REAL SLOPE 00006500 REAL REFNO1 00006600 REAL REFNO2 00006700 REAL RLOCNO 00006800 C 00006900 C CHARACTER ARRAY 00007000 C 00007100 CHARACTER*5 BLANKS 00007200 CHARACTER*80 CARD 00007300 CHARACTER*4 WTD 00007400 C 00007500 C INITIALIZATION 00007600 C 00007700 DATA BLANKS /' '/ 00007800 DATA WTD /'WTD ' / 00007900 C 00008000 C READ WATER DEPTH CARDS 00008100 C ====================== 00008200 C 00008300 C SET LOCAL ERROR FLAGS 00008400 NOERR = 0 00008500 LRTF = 0 00008600 DBILL = 1 00008700 C 00008800 2020 CALL FORC (KPNA,KPRNO,DBILL,CARD, *2230 ) 00008900 COUT IF(S1CPCH(CARD,8,'WTD',1,3).NE.0) GO TO 2020 00009000 IF( CARD(8:10) .NE. WTD(1:3) ) GO TO 2020 00009101 C 00009200 C STARTING SHOTPOINT FOR WATER DEPTHS 00009300 C 00009400 2030 STSHTP = S1CVBN (CARD,11,5) 00009500 COUT IF (S1CPCH(CARD, 11, ' ', 1, 5) .EQ. 0) GO TO 2290 00009600 IF ( CARD(11:15) .EQ. BLANKS(1:5) ) GO TO 2290 00009701 C 00009800 C SEARCH ASPNO ARRAY FOR THIS NUMBER 00010000 C 00010100 DO 2040 00010200 * I = 1,INDEX 00010300 IF(ASPNO(I).EQ.STSHTP) GO TO 2050 00010400 2040 CONTINUE 00010600 C 00010700 LRTF = -1 00010800 NOERR = NOERR + 1 00010900 WRITE (IPR, 9210 ) CARD 00011000 GO TO 2070 00011100 C SAVE THE INDEX FOR WATER DEPTH 00011200 C ARRAY DWATER 00011300 C 00011400 2050 WINDEX = WORK(I) 00011500 C 00011600 C STORE THE WATER DEPTHS IN DWATER 00011700 C 00011800 KNT = WINDEX - 1 00011900 C 00012000 DO 2060 00012100 * I = 21,80,5 00012200 KNT = KNT + 1 00012300 IF(KNT .GT. INDEX) GO TO 2060 00012400 COUT IF(S1CPCH(CARD,I,' ',1,5) .NE. 0) 00012500 IF( CARD(I:I+4) .NE. BLANKS(1:5) ) 00012601 * DWATER(KNT) = S1CVBN(CARD,I,5) 00012700 COUT IF (S1CPCH(CARD, I, ' ', 1, 5) .EQ. 0 .AND. 00012800 IF ( CARD(I:I+4) .EQ. BLANKS(1:5) .AND. 00012901 * I .EQ. 21) GO TO 2280 00013000 C 00013100 2060 CONTINUE 00013200 C 00013300 2070 CALL FORC (KPNA,KPRNO,DBILL,CARD, *2080 ) 00013400 COUT IF(S1CPCH(CARD,8,'WTD',1,3) .EQ. 0) GO TO 2030 00013500 IF( CARD(8:10) .EQ. WTD(1:3) ) GO TO 2030 00013601 C 00013700 C INTERPOLATE MISSING WATER DEPTHS 00013800 C AT SOURCE POINTS. 00013900 C 00014100 2080 CONTINUE 00014200 C 00014300 C FIND FIRST WATER DEPTH CONTROL POINT. 00014400 C 00014500 INDFCP = 0 00014600 DO 2090 I = 1, INDEX 00014700 IF (DWATER(I) .EQ. -9999) GO TO 2090 00014800 C 00014900 C FIRST CONTROL POINT FOUND. 00015000 C 00015100 INDFCP = I 00015200 GO TO 2100 00015301 2090 CONTINUE 00015400 C 00015500 C ERROR. NO CONTROL POINTS FOUND. 00015600 C 00015700 WRITE (IPR,9260) 00015800 LRTF = -1 00015900 NOERR = NOERR + 1 00016000 RETURN 00016100 2100 CONTINUE 00016200 C 00016300 C EXTRAPOLATE TO BEGINNING OF DWATER ARRAY. 00016400 C 00016500 DO 2110 I = 1, INDFCP 00016600 DWATER(I) = DWATER(INDFCP) 00016700 2110 CONTINUE 00016800 2120 CONTINUE 00016900 C 00017000 C FIND NEXT CONTROL POINT. 00017100 C 00017200 INDLCP = 0 00017300 INDFP1 = INDFCP + 1 00017400 IF (INDFP1 .GT. INDEX) GO TO 2160 00017500 DO 2130 I = INDFP1, INDEX 00017600 IF (DWATER(I) .EQ. -9999) GO TO 2130 00017700 INDLCP = I 00017800 GO TO 2140 00017900 2130 CONTINUE 00018000 C 00018100 C NO MORE CONTROL POINTS. THROUGH WITH INTERPOLATION. 00018200 C 00018300 GO TO 2150 00018400 2140 CONTINUE 00018500 C 00018600 C SET UP FOR INTERPOLATION LOOP. 00018700 C 00018800 N2DO = INDLCP - INDFCP - 1 00018900 IF (N2DO .LE. 0) GO TO 2148 00019001 IND = INDFCP + 1 00019100 C 00019200 C CALCULATE SLOPE. 00019300 C 00019400 DIFF = SPLSNO(INDLCP) - SPLSNO(INDFCP) 00019500 IF (DIFF .EQ. 0) SLOPE = 0. 00019600 IF (DIFF .NE. 0) SLOPE = (DWATER(INDLCP) - DWATER(INDFCP)) / DIFF 00019701 C 00019900 C INTERPOLATION LOOP. 00020000 C 00020100 DO 2145 I = 1, N2DO 00020200 DWATER(IND) = DWATER(INDFCP) + SLOPE * (SPLSNO(IND) - 00020300 * SPLSNO(INDFCP)) + 0.5 00020400 IND = IND + 1 00020500 2145 CONTINUE 00020600 C 00020700 C GO BACK TO 2120 FOR NEXT CONTROL POINT. 00020800 C 00020900 2148 CONTINUE 00021000 INDFCP = INDLCP 00021100 IF (INDFCP .LT. INDEX) GO TO 2120 00021200 2150 CONTINUE 00021300 C 00021400 C EXTRAPOLATE TO END OF DWATER ARRAY. 00021500 C 00021600 IF (INDFCP .GE. INDEX) GO TO 2160 00021700 INDFP1 = INDFCP + 1 00021800 DO 2155 I = INDFP1, INDEX 00021900 DWATER(I) = DWATER(INDFCP) 00022000 2155 CONTINUE 00022100 C STORE SOURCE WATER DEPTHS, DEPTH POINT WATER 00022200 C DEPTHS, 00022300 C AND RECEIVER WATER DEPTHS IN TRACE HEADERS 00022400 C 00022500 C N = CURRENT SHOTPOINT INDEX 00022600 C I = CURRENT TRACE NUMBER 00022700 C 00022800 2160 CONTINUE 00022900 NN = 0 00023001 DO 2220 00023100 * N = 1, NOREC, LCTPSP 00023200 C 00023300 NN = NN + 1 00023401 C 00023501 DO 2220 00023600 * I = 1,LCTPSP 00023700 C 00023800 C CURRENT PARAMETER RECORD NUMBER. 00023900 C 00024000 RECNO = N - 1 + I 00024100 C 00024200 C READ THE TRACE HEADER 00024300 C 00024400 WRITNO = RECNO 00024500 CALL USRHDR (TRCHDR, RECNO, *2270 ) 00024600 C 00024700 C SAVE SOURCE WATER DEPTH 00024800 C 00024900 CALL USSTHV (TRCHDR, 'THWDPS ', DWATER(NN)) 00025001 C 00025100 C OBTAIN RECEIVER LOCATION NUMBER 00025200 C OR DEPTH POINT LOCATION NUMBER 00025300 C 00025400 DO 2210 00025501 * J = 1,2 00025601 IF(J.EQ.1)CALL USRTHV(TRCHDR, 'THRCLN ',RLOC) 00025701 IF(J.EQ.2)CALL USRTHV(TRCHDR, 'THCDPL ',RLOC) 00025801 RLOCNO = RLOC/100. 00025901 C 00026000 IF(RLOCNO.GT.SPLSNO(1)) GO TO 2170 00026101 IF(J.EQ.1)CALL USSTHV(TRCHDR, 'THWDPR ', DWATER(1)) 00026201 IF(J.EQ.2)CALL USSTHV(TRCHDR, 'THDPWD ', DWATER(1)) 00026301 GO TO 2210 00026401 C 00026500 2170 IF(RLOCNO.LT.SPLSNO(INDEX)) GO TO 2180 00026601 IF(J.EQ.1)CALL USSTHV(TRCHDR, 'THWDPR ', DWATER(INDEX))00026701 IF(J.EQ.2)CALL USSTHV(TRCHDR, 'THDPWD ', DWATER(INDEX))00026901 GO TO 2210 00027101 C 00027200 2180 INDXM1 = INDEX - 1 00027301 C 00027400 DO 2190 00027501 * K = 1,INDXM1 00027601 IF(RLOCNO.GE.SPLSNO(K) .AND.RLOCNO.LT.SP 00027701 * LSNO(K+1)) GO TO 2200 00027801 C 00027900 2190 CONTINUE 00028000 C 00028100 2200 REFNO1 = SPLSNO(K) 00028200 REFNO2 = SPLSNO(K) 00028300 IF(K+1.LE.INDEX) REFNO2 = SPLSNO(K+1) 00028400 DIFF = REFNO2 - REFNO1 00028500 IF(DIFF.EQ.0.0) RFRAC = 0.0 00028600 IF(DIFF.NE.0.0) RFRAC = INT((RLOCNO - REFNO1) / DIFF) 00028701 DIFF = 0.0 00028800 IF(K+1.LE.INDEX) DIFF = DWATER(K+1) - DWATER(K) 00028900 C 00029000 THWDPR=DIFF*RFRAC+DWATER(K)+0.5 00029200 IF (J .EQ. 1) CALL USSTHV (TRCHDR, 'THWDPR ', THWDPR) 00029301 IF (J .EQ. 2) CALL USSTHV (TRCHDR, 'THDPWD ', THWDPR) 00029501 C 00029700 2210 CONTINUE 00029800 C 00029900 C 00030001 C LWC S 00030101 C IF(I.LT.20) WRITE(IPR, 9407) THWDPR,DWATER(NN) 00030201 C9407 FORMAT(' *** THWDPR, DWATER(NN)', 2I10) 00030301 C LWC E 00030401 C 00030501 C WRITE THE UPDATED TRACE HEADER 00030600 C 00030700 CALL USWHDR (TRCHDR, WRITNO, *2260 ) 00030800 C 00030900 2220 CONTINUE 00031000 C 00031100 GO TO 2250 00031200 C 00031300 C NO WATER DEPTHS SO ZERO OUT 00031400 C DWATER ARRAY. 00031500 C 00031600 2230 DO 2240 00031700 * I = 1,MAXSPS 00031800 DWATER(I) = 0 00031900 2240 CONTINUE 00032000 C 00032100 2250 RETURN 00032200 C 00032300 2260 WRITE(IPR,9220) WRITNO 00032400 LRTF = -1 00032500 NOERR = NOERR + 1 00032600 GO TO 2250 00032700 C 00032800 2270 WRITE (IPR,9230) RECNO 00032900 LRTF = -1 00033000 NOERR = NOERR + 1 00033100 GO TO 2250 00033200 C 00033300 2280 WRITE (IPR, 9240) CARD 00033400 LRTF = -1 00033500 NOERR = NOERR + 1 00033600 GO TO 2250 00033700 C 00033800 2290 WRITE (IPR, 9250) CARD 00033900 LRTF = -1 00034000 NOERR = NOERR + 1 00034100 GO TO 2250 00034200 C 00034300 C 00034400 9210 FORMAT (/,' *** INVALID SHOTPT.NO ***', A80 ) 00034500 C 00034600 9220 FORMAT (/,' *** USWHDR HAD ERROR DA = ', I5) 00034700 C 00034800 9230 FORMAT (/,' *** USRHDR HAD ERROR DA = ', I5) 00034900 C 00035000 9240 FORMAT (/,' ***COLS.21-25 ON WTD CARD MUST NOT BE BLANK'/,1X, A80)00035100 C 00035200 9250 FORMAT (/,' ***COLS.11-15 ON WTD CARD MUST NOT BE BLANK'/,1X, A80)00035300 C 00035400 9260 FORMAT (/,' *** ERROR IN SAGWDC: NO WATER DEPTHS FOUND.') 00035500 C 00035600 END 00036000