CTITLESACUPX -- COUPLING CALCULATION ROUTINE FOR CROSS LINE CDPS C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR T. J. TRULOCK CA DESIGNER T. J. TRULOCK CA LANGUAGE VS FORTRAN CA WRITTEN 05-02-88 C C REVISED MM-DD-YY PROGRAMMER C CA CA CA CALL SACUPX (CDPDA, SHOT1, RECV1, SHOT2, RECV2, MNDP, MXDP, CA MNLNC, MNLN, MXLN, NDPS, SDPN, MAXTRC, KPPRNT, CA MEMTAB, NCORE, MEMCHG, SLN, RCLN, *) CA CA CA IN/OUT ARGUMENT TYPE DESCRIPTION CA CA IN CDPDA I4 DISK ADDRESS TABLE OF GATHERED TRACES CA IN SHOT1 I4 SLN INFO FOR BIN1 CA IN RECV1 I4 RCLN INFO FOR BIN1 CA IN SHOT2 I4 SLN INFO FOR BIN2 CA IN RECV2 I4 RCLN INFO FOR BIN2 CA IN MNDP I4 MINIMUM DEPTH POINT TO PROCESS CA IN MXDP I4 MAXIMUM DEPTH POINT TO PROCESS CA IN MNLNC I4 MINIMUM LINE NO. USED FOR INDEXING CA IN MNLN I4 MINIMUM LINE NO. TO PROCESS CA IN MXLN I4 MAXIMUM LINE NO. TO PROCESS CA IN NDPS I4 NUMBER OF DEPTH POINTS PER LINE CA IN SDPN I4 STARTING DEPTH POINT NUMBER CA IN MAXTRC I4 MAXIMUM TRACE FOLD PER BIN CA IN KPPRNT I4 FORTRAN PRINTER UNIT CA IN MEMTAB I4 TABLE OF 8 WORD TRACE HEADERS CA IN NCORE I4 POINTER TO WHICH MEMORY PAGE IS IN CORE CA IN MEMCHG I4 FLAG SET IF DATA CHANGES IN MEMORY TABLE CA IN SLN I4 FLAG TO USE SHOT LOCATION IN COUPLING CALC CA IN RCLN I4 FLAG TO USE RECV LOCATION IN COUPLING CALC CA CA CA THIS ROUTINE CALCULATES THE COUPLING FRACTION BETWEEN TWO CDPS CA ON ADJACENT LINES. CA CA CAEND C C EJECT C LOCAL OR INTERNAL ARRAYS C C ARGUMENT TYPE LENGTH DESCRIPTION C CDPDA I4 VAR. DISK ADDRESS OF FIRST TRACE IN A CDP CHAIN C SHOT1 I4 MAXTRC WORK ARRAY FOR SLN HEADER INFORMATION -BIN1 C RECV1 I4 MAXTRC WORK ARRAY FOR RCLN HEADER INFORMATION -BIN1 C SHOT2 I4 MAXTRC WORK ARRAY FOR SLN HEADER INFORMATION -BIN2 C RECV2 I4 MAXTRC WORK ARRAY FOR RCLN HEADER INFORMATION -BIN2 C C LOCAL OR INTERNAL VARIABLES AND CONSTANTS C C ARGUMENT TYPE DESCRIPTION C I I4 LOOP INDEX C J I4 LOOP INDEX C DA I4 DISK ADDRESS FOR A TRACE HEADER C BIN I4 COUNTER FOR OUTER DO LOOP; BIN BEING TREATED C MEM I4 POINTER TO START OF HEADER IN MEMORY TABLE C CUPX R4 COUPLING FRACTION BETWEEN TWO CDPS C KEEP I4 POINTER USED IN COMPRESSING ARRAYS C LINE I4 COUNTER FOR INNER DO LOOP; LINE BEING TREATED C MNDP I4 MINIMUM 'DEPTH POINT' (I.E., BIN) NUMBER C MNLN I4 MINIMUM 3D LINE NUMBER C MXDP I4 MAXIMUM 'DEPTH POINT' (I.E., BIN) NUMBER C MXLN I4 MAXIMUM 3D LINE NUMBER C NDA1 I4 INITIAL DISK ADDR OF A CHAIN FOR BIN1 C NDA2 I4 INITIAL DISK ADDR OF A CHAIN FOR BIN2 C NDPS I4 NUMBER OF 'DEPTH POINTS' (I.E., BINS) IN LINE C NRB1 I4 NUMBER OF RECEIVERS IN BIN1 C NRB2 I4 NUMBER OF RECEIVERS IN BIN2 C NSB1 I4 NUMBER OF SHOTS IN BIN1 C NSB2 I4 NUMBER OF SHOTS IN BIN2 C NTB1 I4 NUMBER OF TRACES IN BIN1 C NTB2 I4 NUMBER OF TRACES IN BIN2 C SDPN I4 STARTING 'DEPTH POINT' (I.E., BIN) NUMBER C COMST I4 COUNTER FOR NUMBER OF COMMON SHOTS C INDEX I4 COUNTER FOR NUMBER OF TRACE HEADERS READ SO FAR C NTRCS I4 NUMBER OF TRACES IN BIN C OCUPX R4 PREVIOUS COUPLING FRACTION USED TO HANDLE END AFFECTS C TOTST I4 TOTAL NUMBER OF SHOTS C BINLOC I4 USED IN COMPUTING DISK ADDRESS FOR NEXT HEADER C COMRCV I4 COUNTER FOR NUMBER OF COMMON RECEIVERS C KPPRNT I4 FORTRAN UNIT NUMBER FOR PRINTED OUTPUT C LASTRC I4 VALUE IN TRACE HEADER INDICATING LAST TRACE = -9999 C MAXTRC I4 MAXIMUM NUMBER OF TRACES PER BIN C THCDPN I4 CDP NUMBER C THCUPX I4 EQUIVALENCED INTEGER VALUE TO STORE FLOATING CUPX C INTO INTEGER ARRAY MEMTAB C THLNNO I4 3-D LINE NUMBER C TOTRCV I4 TOTAL NUMBER OF RECEIVERS C C C OTHER SUBROUTINES AND FUNCTIONS CALLED: C C SAMEMT => TO MANAGE MEMORY TABLE FOR HEADER INFORMATION C FLOAT => TO CHANGE INTERGER VALUES TO FLOATING POINT C C C EJECT SUBROUTINE SACUPX(CDPDA, SHOT1, RECV1, SHOT2, RECV2, MNDP, MXDP, * MNLNC, MNLN, MXLN, NDPS, SDPN, MAXTRC, KPPRNT, * MEMTAB, NCORE, MEMCHG, SLN, RCLN, *) C IMPLICIT INTEGER (A-Z) C INTEGER CDPDA(1) INTEGER SHOT1(MAXTRC) INTEGER RECV1(MAXTRC) INTEGER SHOT2(MAXTRC) INTEGER RECV2(MAXTRC) INTEGER MEMTAB(1) C REAL CUPX REAL OCUPX C EQUIVALENCE (CUPX, THCUPX) C C DEBUG PRINT C WRITE(KPPRNT,1)MNDP,MXDP,MNLNC,MNLN,MXLN,NDPS,SDPN,MAXTRC,NCORE, C *MEMCHG,SLN,RCLN C 1 FORMAT(' MNDP MXDP MNLNC MNLN MXLN NDPS ', C * 'SDPN MAXTRC NCORE MEMCHG SLN RCLN',/, C * 1X,12I8) C OCUPX = 0.0 LASTRC=-9999 C C CYCLE THROUGH ALL LINES AND ALL BINS C DO 300 BIN = MNDP, MXDP NTB1 = 0 NTB2 = 0 C WRITE(KPPRNT, 9080) BIN C DO 200 LINE = MNLN, MXLN C C SETUP FOR COLLECTING VALUES FROM TRACE HEADER C INDEX = 0 NTRCS = 0 BINLOC = (LINE-MNLNC) * NDPS + BIN - SDPN + 1 DA = CDPDA(BINLOC) NDA2 = DA C C IF EMPTY BIN -- SKIP COLLECTING VALUES FROM TRACE HEADER C IF(DA.EQ.LASTRC) GO TO 20 10 INDEX = INDEX+1 IF (INDEX .GT. MAXTRC) THEN WRITE(KPPRNT, 9000 ) MAXTRC, BIN, LINE GO TO 200 ENDIF C C GET HEADER WORDS FROM MEMORY TABLE C C DEBUG PRINT C WRITE(KPPRNT,15) DA,INDEX C 15 FORMAT(' DA=',I10,' INDEX=',I10) MEM = ((DA-1) * 8) + 1 PAGE = MEM/8000 MEM = MEM - (PAGE * 8000) PAGE = PAGE + 1 IF(PAGE .NE. NCORE) * CALL SAMEMT(MEMTAB(1), NCORE, PAGE, MEMCHG) DA = MEMTAB(MEM) THLNNO = MEMTAB(MEM+1) THCDPN = MEMTAB(MEM+2) SHOT2(INDEX) = MEMTAB(MEM+3) RECV2(INDEX) = MEMTAB(MEM+4) NTRCS = NTRCS + 1 C C TEST THAT CALCULATED LINE & BIN = LINE & BIN FROM TRACE HEADER C IF(THCDPN .NE. BIN) GO TO 310 IF(THLNNO .NE. LINE) GO TO 320 IF(DA .NE. LASTRC) GO TO 10 C C *** IF EMPTY BIN COME DIRECTLY HERE *** C 20 CONTINUE C C WRITE RESULTS TO PAPER - DEBUG PRINT C C WRITE(KPPRNT, 9020 )LINE,BIN,NTRCS C WRITE(KPPRNT, 9030 ) C WRITE(KPPRNT, 9040 )(SHOT2(I), RECV2(I), I=1, NTRCS) NTB2 = NTRCS IF(NTB1 .EQ. 0) GO TO 150 C C********************************************************************** C * C PERFORM COUPLING * C * C********************************************************************** C CUPX = 0.0 C C COMPUTE COUPLING FOR SLN C IF(NTB2 .EQ. 0) GO TO 130 IF(SLN .NE. 0) THEN COMST = 0 TOTST = 0 KEEP = 1 DO 40 I = 2, NTB1 DO 30 J = 1,KEEP IF(SHOT1(I) .EQ.SHOT1(J)) GO TO 40 30 CONTINUE KEEP = KEEP + 1 SHOT1(KEEP) = SHOT1(I) 40 CONTINUE NSB1 = KEEP KEEP = 1 DO 60 I = 2, NTB2 DO 50 J = 1,KEEP IF(SHOT2(I) .EQ.SHOT2(J)) GO TO 60 50 CONTINUE KEEP = KEEP + 1 SHOT2(KEEP) = SHOT2(I) 60 CONTINUE NSB2 = KEEP C DEBUG PRINT C WRITE(KPPRNT,31) '$$S1', NTB1,NSB1,(SHOT1(I),I=1,NSB1) C 31 FORMAT(1X,A4,10I8,/,5X,10I8,/,5X,10I8) C WRITE(KPPRNT,31) '$$S2', NTB2,NSB2,(SHOT2(I),I=1,NSB2) DO 70 I = 1, NSB1 DO 70 J = 1, NSB2 IF(SHOT2(J) .EQ. SHOT1(I)) COMST = COMST + 1 70 CONTINUE TOTST = NSB1 + NSB2 - COMST ENDIF C C COMPUTE COUPLING FOR RCLN C IF(RCLN .NE. 0) THEN COMRCV = 0 TOTRCV = 0 KEEP = 1 DO 90 I = 2, NTB1 DO 80 J = 1,KEEP IF(RECV1(I) .EQ.RECV1(J)) GO TO 90 80 CONTINUE KEEP = KEEP + 1 RECV1(KEEP) = RECV1(I) 90 CONTINUE NRB1 = KEEP KEEP = 1 DO 110 I = 2, NTB2 DO 100 J = 1,KEEP IF(RECV2(I) .EQ.RECV2(J)) GO TO 110 100 CONTINUE KEEP = KEEP + 1 RECV2(KEEP) = RECV2(I) 110 CONTINUE NRB2 = KEEP C DEBUG PRINT C WRITE(KPPRNT,31) '$$R1', NTB1,NRB1,(RECV1(I),I=1,NRB1) C WRITE(KPPRNT,31) '$$R2', NTB2,NRB2,(RECV2(I),I=1,NRB2) DO 120 I = 1, NRB1 DO 120 J = 1, NRB2 IF(RECV2(J) .EQ. RECV1(I)) COMRCV = COMRCV + 1 120 CONTINUE TOTRCV = NRB1 + NRB2 - COMRCV ENDIF IF(SLN .NE. 0 .AND. RCLN .EQ. 0) THEN CUPX = COMST / FLOAT(TOTST) ENDIF IF(SLN .EQ. 0 .AND. RCLN .NE. 0) THEN CUPX = COMRCV / FLOAT(TOTRCV) ENDIF IF(SLN .NE. 0 .AND. RCLN .NE. 0) THEN CUPX = (COMST + COMRCV) / FLOAT(TOTST + TOTRCV) ENDIF C DEBUG PRINT C WRITE(KPPRNT,333) CUPX C 333 FORMAT(' $$CUPX=',F9.4) C C********************************************************************** C * C WRITE INFORMATION TO TRACE HEADERS FOR BIN1 * C * C********************************************************************** C 130 CONTINUE IF(NTB2 .EQ. 0) CUPX = OCUPX DA = NDA1 140 MEM = ((DA-1) * 8) + 1 PAGE = MEM/8000 MEM = MEM - (PAGE*8000) PAGE = PAGE + 1 IF(PAGE .NE. NCORE) * CALL SAMEMT(MEMTAB(1), NCORE, PAGE, MEMCHG) DA = MEMTAB(MEM) MEMTAB(MEM+6) = THCUPX MEMCHG = 1 IF(DA .NE. LASTRC) GO TO 140 OCUPX = CUPX C C WRITE RESULTS TO PAPER - DEBUG PRINT C C WRITE(KPPRNT, 9020 ) LINE, BIN, NTRCS C WRITE(KPPRNT, 9030 ) C WRITE(KPPRNT, 9040 )(SHOT2(I), RECV2(I), I=1, NTRCS) C C********************************************************************** C * C MOVE BIN2 INTO BIN1 AND GET READY FOR NEXT BIN2 * C * C********************************************************************** C 150 CONTINUE IF(NTB1 .EQ. 0) OCUPX = 0.0 C DO 160 I = 1 , NTB2 SHOT1(I) = SHOT2(I) RECV1(I) = RECV2(I) 160 CONTINUE C NTB1 = NTB2 NTB2 = 0 NDA1 = NDA2 C 200 CONTINUE C C WRITE LAST CHANGES C IF(NTB1 .NE. 0) THEN DA = NDA1 210 MEM = ((DA-1) * 8) + 1 PAGE = MEM/8000 MEM = MEM - (PAGE*8000) PAGE = PAGE + 1 IF(PAGE .NE. NCORE) * CALL SAMEMT(MEMTAB(1), NCORE, PAGE, MEMCHG) DA = MEMTAB(MEM) MEMTAB(MEM+6) = THCUPX MEMCHG = 1 IF(DA .NE. LASTRC) GO TO 210 OCUPX = CUPX ENDIF C 300 CONTINUE C RETURN C C************************ C * C ERROR MESSAGE SECTION * C * C************************ C C CALCULATED AND READ BIN NUMBERS DO NOT AGREE C 310 WRITE(KPPRNT, 9060 ) WRITE(KPPRNT, 9050 ) MNLN, MXLN, LINE, MNDP, * MXDP, BIN, DA, INDEX WRITE(KPPRNT, 9010) DA,(SHOT1(I),I=1,INDEX) GO TO 500 C C CALCULATED AND READ LINE NUMBERS DO NOT AGREE C 320 WRITE(KPPRNT, 9070 ) WRITE(KPPRNT, 9050 ) MNLN, MXLN, LINE, MNDP, * MXDP, BIN, DA, INDEX C 500 RETURN1 C C FORMAT STATEMENTS C 9000 FORMAT(//' SACUPX MAX FOLD GREATER THAN ',I5, * ' FOR BIN ',I5,' LINE ',I5) C 9010 FORMAT (10I7) C 9020 FORMAT('0SACUPX RESULTS FOR 3D LINE ',I5, * ' BIN ',I5,' TRACES = ',I5) C 9030 FORMAT(' ',5(' SHOT RECV ')) C 9040 FORMAT(2X,10I8) C 9050 FORMAT(' MNLN = ',I10,' MXLN = ',I10,' LINE = ',I10, * /' MNDP = ',I10,' MXDP = ',I10,' BIN = ',I10, * /' DISK ADDRESS AT ABEND: DA = ',I10, * /' INDEX = ',I10//) C 9060 FORMAT(//' SACUPX : CALCULATED AND READ BIN NUMBERS', * ' DO NOT AGREE.'//) C 9070 FORMAT(//' SACUPX : CALCULATED AND READ LINE NUMBERS', * ' DO NOT AGREE.'//) C 9080 FORMAT(' CROSS-LINE COUPLING IN PROGRESS FOR BIN',I6) C END