CTITLESARPT2 -- PRINT REPORT FOR TRAC AND AMPS 00000010 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR D.D. REED 00000020 CA DESIGNER D.D. REED 00000030 CA LANGUAGE VS FORTRAN 00000040 CA SYSTEM IBM OR CRAY 00000041 CA WRITTEN 1-04-82 BY DCN FROM SAREPT. 00000050 C REVISED 00000060 C REVISED 04-29-86 JMP. DUAL IBM/CRAY VERSION. 00000070 CA 00000120 CA CALL SARPT2(X, RECTAB, SRCTAB, NMOLOC, SHTNUM, LEN, NTRAC, DIF1, 00000130 CA MINCDP, LS, SQGCT, WK1, WK2, WK3, WK4, WK5, 00000140 CA KPBUGF, IPRNT, FLAG3D, IUNIT) 00000150 CA 00000160 CA INPUT X = COMPONENTS OF PREDICTED VALUE R8 00000170 CA RECTAB = RECEIVER NUMBER HASHING TABLE I4 00000180 CA SRCTAB = SOURCE NUMBER HASHING TABLE I4 00000190 CA NMOLOC = RNMO SOLUTION LOCATION NUMBERS I4 00000200 CA SHTNUM = TABLE OF SHOT LOC. #'S & SHOTPOINT #'S I4 00000210 CA LEN = LENGTH OF RECTAB AND SRCTAB I4 00000220 CA NTRAC = LENGTH OF SHTNUM I4 00000230 CA DIF1 = CDP INDEX BIAS FACTOR I4 00000240 CA MINCDP = MINIMUM CDP # I4 00000250 CA LS = INDEX OF LAST SHOT SOLUTION I4 00000260 CA SQGCT = COUNT OF GATHERS IN SOLUTION ARRAY I4 00000270 CA WK1 = WORK ARRAY R4 00000280 CA WK2 = WORK ARRAY R4 00000290 CA WK3 = WORK ARRAY I4 00000300 CA WK4 = WORK ARRAY I4 00000310 CA WK5 = WORK ARRAY R4 00000320 CA KPBUGF = DEBUG FLAG I4 00000330 CA IPRNT = PRINTER UNIT I4 00000340 CA FLAG3D = 0 NOT 3D LINE I4 00000350 CA = 1 3D LINE 00000360 CA IUNIT = UNITS OF PREDICTED VALUES : 1 = MS. 00000370 CA 2 = DB. 00000380 CA 00000390 CA 00000400 CA PRINT AND PLOT DEPTH POINT, SHOT, AND RECEIVER COMPONENTS 00000410 CA OF STATICS OR AMPLITUDE FACTORS. 00000420 C 00000430 C EJECT 00000440 C 00000450 SUBROUTINE SARPT2(X, RECTAB, SRCTAB, NMOLOC, SHTNUM, LEN, NTRAC, 00000460 * DIF1, MINCDP, LS, SQGCT, WK1, WK2, WK3, WK4, WK5, 00000470 * KPBUGF, IPRNT, FLAG3D, IUNIT) 00000480 C 00000490 C REAL ARRAYS 00000500 C 00000510 REAL WK2 (1) 00000520 REAL WK5 (1) 00000530 DOUBLE PRECISION X (1) 00000540 C 00000550 C INTEGER ARRAYS 00000560 C 00000570 INTEGER RECTAB (1) 00000580 INTEGER NMOLOC (1) 00000590 INTEGER SHTNUM (1) 00000600 INTEGER SRCTAB (1) 00000610 INTEGER WK1 (1) 00000620 INTEGER WK3 (1) 00000630 INTEGER WK4 (1) 00000640 C 00000650 C INTEGER VARIABLES AND CONSTANTS 00000660 C 00000670 INTEGER DA 00000680 INTEGER DIF1 00000690 INTEGER KPBUGF 00000700 INTEGER MINCDP 00000710 INTEGER SQGCT 00000720 C 00000730 C ORDER ORIGINAL RECEIVER NUMBERS AND SOLUTIONS 00000740 C 00000750 IF (KPBUGF .NE. 0 .AND. IUNIT .EQ. 1) WRITE (IPRNT, 1000) 00000760 IF (KPBUGF .NE. 0 .AND. IUNIT .EQ. 2) WRITE (IPRNT, 1010) 00000770 C 00000780 C INITIALIZE LAST NUMBER IN ARRAY, NEXT LOCATION 00000790 C 00000800 LNUM = -999999 00000810 NRECS = 1 00000820 LEN = LEN * 3 00000830 C 00000840 C TABLE SHOULD USUALLY BE NEARLY ORDERED. READ 00000850 C SEQUENTIALLY + FOLLOW POINTERS TO FILL IN PRINT 00000860 C ARRAYS WITH AS LITTLE SEARCHING AS POSSIBLE. 00000870 C 00000880 00000890 00000900 DO 90 00000910 * K = 1, LEN, 3 00000920 C 00000930 C J POINTS TO CELL TO INSERT IN ARRAY 00000940 C NUM = ORIGINAL RECEIVER NUMBER 00000950 C IF NUM IS < LAST NUMBER IN ARRAY, GO SEARCH FOR 00000960 C PROPER LOCATION. 00000970 C 00000980 J = K 00000990 C 00001000 C IF THIS CELL EMPTY OR ALREADY IN PRINT ARRAY? 00001010 C 00001020 10 IF (RECTAB(J+1) .EQ. 0) GO TO 90 00001030 NUM = RECTAB(J) 00001040 IF (NUM .LT. LNUM) GO TO 30 00001050 C 00001060 C ADD INFO. FROM CELL TO ARRAY, SET SEQ. # TO ZERO 00001070 C TO INDICATE CELL HAS BEEN USED. UPDATE LAST NUMBER00001080 C IN ARRAY AND NEXT LOCATION POINTER. 00001090 C 00001100 LNUM = NUM 00001110 WK1(NRECS) = NUM 00001120 WK2(NRECS) = X(RECTAB(J+1)) 00001130 WK3(NRECS) = RECTAB(J+1) 00001140 20 RECTAB(J+1) = 0 00001150 NRECS = NRECS + 1 00001160 C 00001170 C FOLLOW POINTER TO ANOTHER CELL IF PRESENT 00001180 C 00001190 IF (RECTAB(J+2) .EQ. 0) GO TO 90 00001200 J = RECTAB(J+2) 00001210 GO TO 10 00001220 C 00001230 C SEARCH BACKWARDS FOR LOCATION FOR THIS NUMBER 00001240 C 00001250 30 KK = NRECS - 1 00001260 C 00001270 C NUMBER IS TO BE LOCATED AT TOP OF ARRAY 00001280 C 00001290 IF (KK .GE. 2) GO TO 40 00001300 NDX = 1 00001310 GO TO 70 00001320 C 00001330 40 DO 50 00001340 * I = 2, KK 00001350 IF (NUM .GT. WK1(NRECS-I)) GO TO 60 00001360 50 CONTINUE 00001370 C 00001380 NDX = KK 00001390 GO TO 70 00001400 C 00001410 60 NDX = I - 1 00001420 C 00001430 C MOVE ARRAY ELEMENTS TO MAKE ROOM FOR NUMBER 00001440 C 00001450 70 DO 80 00001460 * L = 1, NDX 00001470 WK1(NRECS-L+1) = WK1(NRECS-L) 00001480 WK2(NRECS-L+1) = WK2(NRECS-L) 00001490 WK3(NRECS-L+1) = WK3(NRECS-L) 00001500 80 CONTINUE 00001510 C 00001520 C FILL IN ARRAY ELEMENT 00001530 C 00001540 WK1(NRECS-NDX) = NUM 00001550 WK2(NRECS-NDX) = X(RECTAB(J+1)) 00001560 WK3(NRECS-NDX) = RECTAB(J+1) 00001570 GO TO 20 00001580 C 00001590 90 CONTINUE 00001600 C 00001610 C PRINT ORIGINAL REC. #'S AND SOLUTIONS 00001620 C 00001630 NRECS = NRECS - 1 00001640 IF (KPBUGF .EQ. 0) GO TO 110 00001650 00001660 DO 100 00001670 * I = 1, NRECS 00001680 WRITE (IPRNT, 1060) WK1(I), WK3(I), WK2(I), I 00001690 100 CONTINUE 00001700 00001710 C 00001720 C ORDER ORIG. SHOT #'S AND SOLUTIONS IN ARRAYS 00001730 C 00001740 110 LNUM = -999999 00001750 NSHOT = 1 00001760 IF (KPBUGF .NE. 0 .AND. IUNIT .EQ. 1) WRITE (IPRNT, 1020) 00001770 IF (KPBUGF .NE. 0 .AND. IUNIT .EQ. 2) WRITE (IPRNT, 1030) 00001780 C 00001790 C TABLE SHOULD USUALLY BE NEARLY ORDERED. BRANCH 00001800 C THRU FOLLOWING POINTERS AND FILL IN PRINT ARRAYS 00001810 C 00001820 DO 200 00001830 * K = 1, LEN, 3 00001840 C 00001850 C J POINTS TO CELL TO STUFF IN ARRAY 00001860 C NUM = ORIGINAL SHOT NUMBER 00001870 C IF NUM < LAST NUMBER, SEARCH FOR PROPER SPOT 00001880 C 00001890 J = K 00001900 C 00001910 C IS CELL EMPTY? 00001920 C 00001930 120 IF (SRCTAB(J+1) .EQ. 0) GO TO 200 00001940 NUM = SRCTAB(J) 00001950 IF (NUM .LT. LNUM) GO TO 140 00001960 C 00001970 C FILL IN ARRAY WITH INFO. FROM CELL 00001980 C 00001990 LNUM = NUM 00002000 WK4(NSHOT) = NUM 00002010 WK5(NSHOT) = X(SRCTAB(J+1)) 00002020 WK3(NSHOT) = SRCTAB(J+1) 00002030 C 00002040 C SET "CELL HAS BEEN USED" FLAG AND NEXT LOCATION # 00002050 C 00002060 130 SRCTAB(J+1) = 0 00002070 NSHOT = NSHOT + 1 00002080 C 00002090 C FOLLOW POINTER TO NEXT CELL IF PRESENT 00002100 C 00002110 IF (SRCTAB(J+2) .EQ. 0) GO TO 200 00002120 J = SRCTAB(J+2) 00002130 GO TO 120 00002140 C 00002150 C SEARCH BACKWARDS FOR PROPER LOCATION FOR NUM 00002160 C 00002170 140 KK = NSHOT - 1 00002180 IF (KK .GE. 2) GO TO 150 00002190 NDX = 1 00002200 GO TO 180 00002210 C 00002220 150 DO 160 00002230 * I = 2, KK 00002240 IF (NUM .GT. WK4(NSHOT-I)) GO TO 170 00002250 160 CONTINUE 00002260 C 00002270 NDX = KK 00002280 GO TO 180 00002290 C 00002300 170 NDX = I - 1 00002310 C 00002320 C MOVE ARRAY ELEMENTS TO MAKE ROOM FOR NUMBER 00002330 C 00002340 180 DO 190 00002350 * L = 1, NDX 00002360 WK4(NSHOT-L+1) = WK4(NSHOT-L) 00002370 WK5(NSHOT-L+1) = WK5(NSHOT-L) 00002380 WK3(NSHOT-L+1) = WK3(NSHOT-L) 00002390 190 CONTINUE 00002400 C 00002410 C FILL ARRAY ELEMENTS WITH NUMBER AND SOLUTION 00002420 C 00002430 WK4(NSHOT-NDX) = NUM 00002440 WK5(NSHOT-NDX) = X(SRCTAB(J+1)) 00002450 WK3(NSHOT-NDX) = SRCTAB(J+1) 00002460 GO TO 130 00002470 C 00002480 200 CONTINUE 00002490 C 00002500 C PRINT ORIGINAL SHOT #'S AND SOLUTIONS 00002510 C 00002520 NSHOT = NSHOT - 1 00002530 IF (KPBUGF .EQ. 0) GO TO 220 00002540 C 00002550 DO 210 00002560 * I = 1, NSHOT 00002570 WRITE (IPRNT, 1060) WK4(I), WK3(I), WK5(I), I 00002580 210 CONTINUE 00002590 C 00002600 220 CONTINUE 00002610 C 00002620 DO 240 00002630 * I = 1, NSHOT 00002640 C 00002650 DO 230 00002660 * J = 1, NTRAC, 2 00002670 IF (WK4(I) .NE. SHTNUM(J)) GO TO 230 00002680 SRCTAB(I) = SHTNUM(J+1) 00002690 GO TO 240 00002700 230 CONTINUE 00002710 C 00002720 WRITE (IPRNT, 1100) WK4(I) 00002730 SRCTAB(I) = 0 00002740 240 CONTINUE 00002750 C 00002760 K = LS + 1 00002770 KK = LS + LD 00002780 C 00002790 DO 250 00002800 * I = 1, SQGCT 00002810 WK3(I) = I - DIF1 00002820 250 CONTINUE 00002830 C 00002840 IF (KPBUGF .EQ. 0 .AND. FLAG3D .EQ. 0) GO TO 300 00002850 C 00002860 C PRINT OFFSET SOLUTIONS 00002870 C 00002880 IF (IUNIT .EQ. 2) WRITE (IPRNT, 1040) 00002890 IF (IUNIT .EQ. 1) WRITE (IPRNT, 1050) 00002900 C 00002910 DO 260 00002920 * I = 1, SQGCT 00002930 WRITE (IPRNT,1070) NMOLOC(I), WK3(I), X(LS+I), X(I), I 00002940 260 CONTINUE 00002950 C 00002960 C GENERATE PRINTER PLOT 00002970 C 00002980 300 CALL USSCP2 (SRCTAB, WK4, WK5, NSHOT, WK1, 00002990 * WK2, NRECS, NMOLOC, X(LS+1), SQGCT, 00003000 * X, MINCDP, 10, 50, IPRNT, 00003010 * FLAG3D, IUNIT) 00003020 C 00003030 C FORMATS 00003040 C 00003050 1000 FORMAT(///' RECEIVER STATIC SOLUTION' 00003060 * /' ========================' 00003070 * //' LOCATION MODIFIED RECEIVER SEQ. #', 00003080 * /' NUMBER REC. # SOLUTION') 00003090 C 00003100 1010 FORMAT(///' RECEIVER AMPLITUDE SOLUTION' 00003110 * /' ===========================' 00003120 * //' LOCATION MODIFIED RECEIVER SEQ. #', 00003130 * /' NUMBER REC. # SOLUTION') 00003140 C 00003150 1020 FORMAT(///' SHOT STATIC SOLUTION' 00003160 * /' ====================' 00003170 * //' LOCATION MODIFIED SHOT SEQ. #', 00003180 * /' NUMBER SHOT # SOLUTION') 00003190 C 00003200 1030 FORMAT(///' SHOT AMPLITUDE SOLUTION' 00003210 * /' =======================' 00003220 * //' LOCATION MODIFIED SHOT SEQ. #', 00003230 * /' NUMBER SHOT # SOLUTION') 00003240 C 00003250 1040 FORMAT(///' OFFSET AMPLITUDE SOLUTION AND RMS SOLUTION ERROR' 00003260 * /' ================================================' 00003270 * //' LOCATION DEPTH PT OFFSET SOLUTION SEQ. #' 00003280 * /' NUMBER NUMBER SOLUTION ERROR') 00003290 C 00003300 1050 FORMAT(///' RNMO STATIC SOLUTION AND RMS SOLUTION ERROR' 00003310 * /' ===========================================' 00003320 * //' LOCATION DEPTH PT RNMO SOLUTION SEQ. #' 00003330 * /' NUMBER NUMBER SOLUTION ERROR') 00003340 C 00003350 1060 FORMAT (' ',I8,I10, F12.4,3X,I5) 00003360 C 00003370 1070 FORMAT (' ',I8,I10,2F12.4,3X,I5) 00003380 C 00003390 1100 FORMAT (' *** NO SHOTPOINT NUMBER LOCATED FOR LOCATION NUMBER ', 00003400 * I9) 00003410 C 00003420 RETURN 00003430 C 00003440 END 00003450