CTITLESDZMPS -- 2-D 30-DEGREE PRE-STACK DEPTH MIGRATION 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR F. G. SHERRILL/R. D. KNIGHT 00000200 CA DESIGNER R. D. KNIGHT 00000300 CA LANGUAGE VS FORTRAN 00000400 CA SYSTEM S/370 00000500 CA WRITTEN SUMMER 1980 00000600 C REVISED RDK; FEB/MAR 83; IMPLEMENTATION IN SPARC. 00000700 C REVISED 10/12/83 GEM. CHANGED DISK ADRR/PARM TABLE END 00000710 C VALUE TO NINE 9'S. 00000720 C REVISED 10/04/84 NAM. VSFORTRAN CONVERSION. ADDED CARRAY 00000730 C AND EQUIVALENCES. CHANGED '&' TO '*' 00000740 C FOR ERROR RETURN ADDRESSES. 00000750 C REVISED 05/09/85 RKG. CHANGED TO CALL UPAWRK INSTEAD OF 00000760 C UGAWRK. 00000770 C REVISED 04/28/88 TJT. MADE LCGRPI FLOATING POINT. C REVISED 06/24/88 TJT. MADE LCGRPI FLOATING PT. CHANGE C PERMANENT. C 00000800 CA 00000900 CA 00001000 CA CALL SDZMPS (INH, INTR, OH, OTR) 00001100 CA 00001200 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00001300 CA 00001400 CA IN INH MIXED INPUT HEADER 00001500 CA IN INTR R4 INPUT TRACE 00001600 CA OUT OH MIXED OUTPUT HEADER 00001700 CA OUT OTR R4 OUTPUT TRACE 00001800 CA 00001900 CA 00002000 C 00002100 C EJECT A NEW PAGE MAY BE DESIRABLE HERE. PUT EJECT IN COL. 7. 00002200 C 00002300 C LOCAL OR INTERNAL ARRAYS. 00002400 C 00002500 C DATTR ( 96) = DATA ATTRIBUTES STORAGE I4 00002600 C DENTRY ( 104) = PARAMETER STORAGE I4 00002700 C DLOCAL ( XXX) = LOCAL VARIABLES STORAGE I4 00002800 C INH ( 1) = INPUT TRACE HEADER I4 00002900 C INTR ( 1) = INPUT TRACE AREA R4 00003000 C OH ( 1) = OUTPUT TRACE HEADER I4 00003100 C OTR ( 1) = OUTPUT TRACE AREA R4 00003200 C PSHOT ( 12) = PROCESSED DEPTH POINTS I4 00003300 C 00003400 C LOCAL OR INTERNAL VARIABLES AND CONSTANTS. 00003500 C 00003600 C BCDPN = BEGINNING DEPTH POINT TO PROCESS 00003700 C BUFL = NEXT WORD ADDRESS FOR TRANSFORM DATA IN SAVE AREA 00003800 C CDP = NUMBERS OF MIGRATED CDP'S OUTPUT 00003900 C CSAVE = COUNTER FOR NUMBER OF MIGRATED CDP'S OUTPUT 00004000 C DAWRK = ADDRESS OF NEXT RECORD FROM WORK FILE (USUALLY #1)00004100 C DAWRK2 = ADDRESS OF NEXT RECORD FROM WORK FILE (USUALLY #2)00004200 C DIP = MAXIMUM DIP IN THE DATA (USER PARAMETER) 00004300 C DIPC = DIP FILTERING CONSTANT 00004400 C DOM = FREQUENCY SAMPLING INCREMENT 00004500 C DT = SAMPLE RATE OF TRACE DATA 00004600 C DX = CDP SPACING OF THE DATA 00004700 C DZ = DEPTH INCREMENT OR SPACING 00004800 C ECDPN = END DEPTH POINT TO PROCESS 00004900 C ETA = DIP FILTERING CONSTANT 00005000 C HFRQ = HIGHEST FREQUENCY OF INTEREST IN DATA 00005100 C LFRQ = LOWEST FREQUENCY OF INTEREST IN DATA 00005200 C ICO = COUNTER FOR TRACES SAMPLED IN SECTION EQUALIZE 00005300 C IDDATM = DEPTH OF THE DATUM PLANE 00005400 C IFLAG = INDICATES OPERATION TO BE PERFORMED 00005500 C = 'M' FOR MIGRATION 00005600 C = 'D' FOR DATUMING 00005700 C IFLT = LENGTH OF BANDWIDTH DETERMINATION SMOOTHING FILTER00005800 C IMEM = MAXIMUM MEMORY REQUIREMENT FOR THIS OCCURRENCE 00005900 C IMEM1 = MEMORY REQUIRED INITIALIZATION STEP 00006000 C IMEM2 = MEMORY REQUIREMENT IN SCRATCH FILE INITIALIZATION 00006100 C IMEM3 = RESERVED COMMON REQUIRED IN TRACE SAVE OPERATION 00006200 C IMEM4 = UNRESERVED COMMON REQUIRED FOR MIGRATION 00006300 C IUP = INDICATES WHETHER TO BRING DATA BACK TO SURFACE 00006400 C = 1 FOR DATUMING ONLY 00006500 C = 2 BRING DATA BACK TO SURFACE 00006600 C IVDATM = REPLACEMENT VELOCITY FOR BRINGING DATA TO SURFACE 00006700 C LC = CONVOLUTION LENGTH IN BANDWIDTH DETERMINATION 00006800 C NEXP = BASE 2 EXPONENT OF AUGMENTED TRACE LENGTH 00006900 C NFB = NUMBER OF FREQUENCY BLOCKS IN DATA BLOCKING 00007000 C NFCPB = NUMBER OF FREQUENCY COMPONENTS PER BLOCK FACTOR 00007100 C NLO = LOWER LIMIT OF OPERATING BANDWIDTH OF DATA 00007200 C NHI = UPPER LIMIT OF OPERATING BANDWIDTH OF DATA 00007300 C NOM = NUMBER OF FREQUENCIES TO MIGRATE 00007400 C NOMLO = INDEX OF LFRQ IN FOURIER TRANSFORM OF DATA 00007500 C NOMHI = INDEX OF HFRQ IN FOURIER TRANSFORM OF DATA 00007600 C NS = INDEX/COUNTER FOR ARRAY PSHOT 00007700 C NTB = NUMBER OF TRACE BLOCKS IN DATA BLOCKING 00007800 C NTPB = NUMBER OF TRACES PER BLOCK IN DATA BLOCKING 00007900 C NT = TRACELENGTH AS DEFINED FOR MIGRATION OPERATION 00008000 C NTE = LENGTH OF TRUNCATED FFT IN MIGRATION OPERATION 00008100 C NTT = AUGMENTED TRACE LENGTH (RADIX 2 BASE FOR NT) 00008200 C NUMT = ACTUAL TRACELENGTH OF INPUT TRACES 00008300 C NX = NUMBER OF TRACES TO MIGRATE 00008400 C NZ = NUMBER OF DEPTH STEPS BASED ON INPUT HORIZONS 00008500 C OR INPUT BY USER 00008600 C NZB = NUMBER OF DEPTH(Z) BLOCKS IN DATA BLOCKING 00008700 C NZCPB = NUMBER OF Z COMPONENTS PER DATA BLOCK 00008800 C NZF = NUMBER OF DEPTH STEPS USED IN MIGRATION 00008900 C SCALE = SCALE FACTOR USED TO EQUALIZE SECTION AFTER ZMPS 00009000 C TCNT = TRACE COUNTER FOR DATA SAVE STEP 00009100 C THL = TRACE HEADER LENGTH 00009200 C TNS = INDEX/COUNTER FOR PSHOT 00009300 C VMAX = MAX DIFFERENTIAL CHANGE IN VELOCITY OVER SECTION 00009400 C 00009500 C ===================================================================== 00009600 C FORMAT OF OUTPUT PARAMETER RECORDS 00009700 C 00009800 C ****** FIRST RECORD ****** PROCESSING RANGE ****** 00009900 C ===================================================================== 00010000 C 00010100 C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 00010200 C |_______|________|_______|_______|_______|_______|_________|________| 00010300 C | ZMPS | PROCESS| PTS | FIRST | NOT |# OF |N|S|NOT | NOT | 00010400 C |_______|_NUMBER_|_______|_SHOT__|_USED__|__PARMS|_|_|USED_|_USED___| 00010500 C 00010600 C WORD 9 WORD 10 00010700 C |_______|________| 00010800 C |FIRST |LAST | 00010900 C |_SHOTPT|_SHOTPT_| 00011000 C 00011100 C ===================================================================== 00011200 C FORMAT OF OUTPUT PARAMETER RECORDS 00011300 C 00011400 C ******SECOND RECORD ****** PROCESSING PARAMETERS ****** 00011500 C ===================================================================== 00011600 C 00011700 C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 00011800 C |_______|________|_______|_______|_______|_______|_________|________| 00011900 C | ZMPS | PROCESS| PRM | FIRST | NOT |# OF |N|S|NOT | NOT | 00012000 C |_______|_NUMBER_|_______|_SHOT__|_USED__|__PARMS|_|_|USED_|_USED___| 00012100 C 00012200 C WORD 9 WORD 10 WORD 11 WORD 12 WORD 13 WORD 14 WORD 15 WORD 16 00012300 C |_______|________|_______|_______|___________|_______|______|_______| 00012400 C |FIRST |LAST | MAX |LOWEST | HIGHEST | OUTPUT| Z |Z-STEP | 00012500 C |_SHOTPT|_SHOTPT_|_DIP___|_FREQ__|_FREQUENCY_|_TYPE__|_STEPS|_SIZE__| 00012600 C 00012700 C WORD 17 WORD 18 WORD 19 WORD 20 WORD 21 WORD 22 00012800 C |_______|________|_______|________|________|_________| WORDS 23-28 00012900 C | DATUM |MAX LEFT|MAX RT | TOTAL | SHOT | STATION | NOT USED 00013000 C |_DEPTH_|RECVRS__|RECVRS_|_SHOTS__|SPACING_|_SPACING_| 00013100 C 00013200 C WORD 29 WORD 30 WORD 31 00013300 C |_______|________|_______| 00013400 C | MAX | MAX | MAX | 00013500 C |_HORIZS|SEGMENTS|POINTS_| 00013600 C 00013700 C ===================================================================== 00013800 C FORMAT OF OUTPUT PARAMETER RECORDS 00013900 C 00014000 C ***** REMAINING RECORDS ****** HORIZON SPECIFICATIONS ****** 00014100 C ===================================================================== 00014200 C 00014300 C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 00014400 C |_______|________|_______|_______|_______|_______|_________|_______| 00014500 C | ZMPS | PROCESS| HRZ | NOT | NOT |# OF |N|S|NOT | NOT | 00014600 C |_______|_NUMBER_|_______|_USED__|_USED__|__PARMS|_|_|USED_|_USED__| 00014700 C 00014800 C WORD 9 WORD 10 WORD 11 WORD 12 WORD 13-------------> WORD 98 00014900 C |_______|________|_______|_______|________|________________|_______| 00015000 C |HORIZON|SEGMENT | X-- | Z-- |VELOCITY| | | 00015100 C |NUMBER_|_NUMBER_|_COOR__|__COOR_|________|________________|_______| 00015200 C 00015300 C ===================================================================== 00015400 C 00015500 C RESERVED COMMON AREA 00015600 C SECTION DEFINITIONS: 00015700 C 00015800 C KPIRSM <---------------------| 00015900 C | RESERVED FOR | 00016000 C | LOCAL VARIABLES| ---> LLOCAL 00016100 C | AND CONSTANTS | 00016200 C |----------------| 00016300 C | TRACE HEADER | ---> THL 00016400 C |----------------| 00016500 C | FILTER OPERATOR| 00016600 C | FOR BANDWIDTH | ---> IFLT 00016700 C | DETERMINATION | 00016800 C |----------------| 00016900 C | SAVE AREA FOR | 00017000 C | TRANSFORM DATA | 00017100 C | DURING TRACE | ---> 2*NFCPB*NFC*NTPB 00017200 C | SAVE OPERATION | 00017300 C | (INITIAL PASS) | 00017400 C ------------------ 00017500 C 00017600 C ==================================================================== 00017700 C 00017800 SUBROUTINE SDZMPS (INH, INTR, OH, OTR) 00017900 C 00018000 IMPLICIT INTEGER (A-Z) 00018100 EXTERNAL FOIP 00018200 EXTERNAL FOSCDK 00018300 EXTERNAL S1ATP 00018400 C 00018500 C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 11/28/83 00018600 COMMON /P/ STARTP 00018610 REAL *8 STARTP 00018620 COMMON /P/ LCNAME 00018630 COMMON /P/ LC5 00018640 COMMON /P/ LCINT 00018650 COMMON /P/ LCTYP 00018660 COMMON /P/ LC10 00018670 COMMON /P/ LCBGSP 00018680 COMMON /P/ LCENSP , M00032( 2) 00018690 COMMON /P/ LCNSP 00018700 COMMON /P/ LCTPSP 00018710 COMMON /P/ LCRL 00018720 COMMON /P/ LCSI 00018730 COMMON /P/ LCPI 00018740 COMMON /P/ LCGRPI 00018750 COMMON /P/ LCMXFD , M00068( 2) 00018760 COMMON /P/ LCDRYF , M00080( 3) 00018770 COMMON /P/ ACNAME 00018780 COMMON /P/ AC0506 00018790 COMMON /P/ AC64BC 00018800 COMMON /P/ ACOPCD 00018810 COMMON /P/ ACQCF 00018820 COMMON /P/ ACDIST 00018830 COMMON /P/ ACPROJ 00018840 COMMON /P/ ACLNAM ( 5) 00018850 COMMON /P/ ACCOM ( 8) 00018860 COMMON /P/ AC7274 00018870 COMMON /P/ ACTYPE 00018880 COMMON /P/ ACNSP 00018890 COMMON /P/ ACUSER ( 5) , M00188( 12) 00018900 COMMON /P/ LHJBNO 00018910 COMMON /P/ LHLNO 00018920 COMMON /P/ LHRLNO 00018930 COMMON /P/ LHTPSP 00018940 COMMON /P/ LHATSP 00018950 COMMON /P/ LHSI 00018960 COMMON /P/ LHORSI 00018970 COMMON /P/ LHST 00018980 COMMON /P/ LHORST 00018990 COMMON /P/ LHDFCD 00019000 COMMON /P/ LHEXFD 00019010 COMMON /P/ LHTSCD 00019020 COMMON /P/ LHVSCD 00019030 COMMON /P/ LHSWFS 00019040 COMMON /P/ LHSWFE 00019050 COMMON /P/ LHSWL 00019060 COMMON /P/ LHSWCD 00019070 COMMON /P/ LHTSNO 00019080 COMMON /P/ LHSWTS 00019090 COMMON /P/ LHSWTE 00019100 COMMON /P/ LHSWTT 00019110 COMMON /P/ LHTCF 00019120 COMMON /P/ LHBGRF 00019130 COMMON /P/ LHARCD 00019140 COMMON /P/ LHMS 00019150 COMMON /P/ LHSGPL 00019160 COMMON /P/ LHVPCD 00019170 COMMON /P/ LHNSP 00019180 COMMON /P/ LHNDP 00019190 COMMON /P/ LHNSL 00019200 COMMON /P/ LHMTPR , M00376( 9) 00019210 COMMON /P/ KPNA 00019220 COMMON /P/ KPRNO , M00420 00019230 COMMON /P/ KPA 00019240 COMMON /P/ KPDBGS 00019250 COMMON /P/ KPDBGA 00019260 COMMON /P/ KPDBGN 00019270 COMMON /P/ KPWRKS 00019280 COMMON /P/ KPWRKD 00019290 COMMON /P/ KPWKS2 00019300 COMMON /P/ KPWKD2 00019310 COMMON /P/ KPWKS3 00019320 COMMON /P/ KPWKD3 00019330 COMMON /P/ KPFCF 00019340 COMMON /P/ KPIRSM 00019350 COMMON /P/ KPNRSM 00019360 COMMON /P/ KPIUSM 00019370 COMMON /P/ KPNUSM 00019380 COMMON /P/ KPTIME 00019390 COMMON /P/ KPRTF 00019400 COMMON /P/ KPDRTF 00019410 COMMON /P/ KPMOTF 00019420 COMMON /P/ KPNBR 00019430 COMMON /P/ KPIBN 00019440 COMMON /P/ KPITSV 00019450 COMMON /P/ KPTAMF 00019460 COMMON /P/ KPLOTF 00019470 COMMON /P/ KPMITF 00019480 COMMON /P/ KPPRNT 00019490 COMMON /P/ KPPLOT 00019500 COMMON /P/ KPPLTA 00019510 COMMON /P/ KPBUGF , M00540( 226) 00019520 COMMON /P/ ENDP 00019530 C REAL LCGRPI C 00019540 COMMON COM (1) 00019550 REAL XCOM(1) 00019560 EQUIVALENCE (COM(1),XCOM(1)) 00019570 C 00019580 C EXTERNAL FGQSAM 00019590 C EXTERNAL FGSCDK 00019600 C EXTERNAL FGTRCE 00019610 C 00019630 C=================================================================== 00019640 C 00019650 C REAL ARRAYS IN PARAMETER LIST 00019660 C 00019670 REAL INH(1) 00019680 REAL OTR(1) 00019690 REAL OH (1) 00019700 REAL INTR(1) 00019710 C 00019720 C=================================================================== 00019730 C 00019740 C REAL CONSTANTS--LOCAL 00019750 C 00019760 REAL A1 / -4.34E-05/ 00019770 REAL A2 / 4.03226E-02/ 00019780 REAL A3 / 2.6668296/ 00019790 REAL A4 / 0.001/ 00019800 C REAL A5 / 0.00001/ 00019810 REAL C1 / 7.0122574/ 00019820 REAL C2 /-0.115197E-01/ 00019830 REAL C3 /-0.737700E-03/ 00019840 REAL C4 / 1.00/ 00019850 REAL C5 /-0.90556 E-02/ 00019860 REAL C6 / 0.261100E-03/ 00019870 REAL Q1 / 0.8/ 00019880 REAL Q2 / 0.3/ 00019890 REAL TWOPI / 6.2831853/ 00019900 C 00019910 REAL AMAX1 00019920 REAL AMIN1 00019930 REAL ANZ 00019940 REAL ATTR ( 96) 00019950 REAL BETA 00019960 REAL*8 CCW ( 20) 00019970 REAL DIP 00019980 REAL DIPC 00019990 REAL DOM 00020000 REAL DT 00020010 REAL DX 00020020 REAL DZ 00020030 REAL ETA 00020040 REAL HFRQ 00020050 REAL LFRQ 00020060 REAL SCAL 00020070 REAL SCALE 00020080 REAL T 00020090 REAL VMAX 00020100 REAL VMIN 00020110 C 00020120 REAL ZZ,CDPLQ,DXCDP,RTCDP,DXR,DXS,DXST,RTO,STO 00020130 REAL ATO,ATO100,TRAC1,TRACN,SHT1,REC1,ASHOT 00020140 REAL SSP,SHOT,AREAL,ATEST 00020150 C 00020160 C=================================================================== 00020170 C 00020180 C INTEGER ARRAYS--LOCAL 00020190 C 00020200 INTEGER DATTR ( 96) 00020210 INTEGER DENTRY (104) 00020220 INTEGER DLOCAL (150) 00020230 INTEGER NOUT ( 02) 00020240 INTEGER PSHOT ( 12) 00020250 C 00020260 C DENTRY IS AN ARRAY TO HOLD A PARAMETER RECORD. THE DEFINITIONS 00020270 C OF THE FIRST EIGHT WORDS ARE FIXED. THE REMAINING WORDS ARE 00020280 C FOR VARIABLE PARAMETERS AND ARE USUALLY ADDRESSED USING "DATTR". 00020290 C THE MAXIMUM LENGTH OF DENTRY IS 104 BECAUSE OF THE I/O ROUTINES. 00020300 C 00020310 EQUIVALENCE (DCTYP , DENTRY (03)) 00020320 EQUIVALENCE (SPT , DENTRY (04)) 00020330 EQUIVALENCE (EPT , DENTRY (05)) 00020340 EQUIVALENCE (NOPAR , DENTRY (06)) 00020350 EQUIVALENCE (PMODE , DENTRY (07)) 00020360 EQUIVALENCE (SPLOCN , DENTRY (08)) 00020370 EQUIVALENCE (DATTR(1) , DENTRY (09)) 00020380 C 00020390 EQUIVALENCE (DATTR(1) , ATTR (01)) 00020400 C 00020410 C DLOCAL IS AN ARRAY USED TO HOLD PARAMETER VALUES THAT ARE UNIQUE 00020420 C TO EACH OCCURRENCE OF THE PROCESS. 00020430 C 00020440 EQUIVALENCE (CSAVE , DLOCAL (04)) 00020450 EQUIVALENCE (DAWRK , DLOCAL (05)) 00020460 EQUIVALENCE (DAWRK2 , DLOCAL (06)) 00020470 EQUIVALENCE (DIP , DLOCAL (07)) 00020480 EQUIVALENCE (DIPC , DLOCAL (08)) 00020490 EQUIVALENCE (DOM , DLOCAL (09)) 00020500 EQUIVALENCE (DT , DLOCAL (10)) 00020510 EQUIVALENCE (DX , DLOCAL (11)) 00020520 EQUIVALENCE (DZ , DLOCAL (12)) 00020530 EQUIVALENCE (ETA , DLOCAL (14)) 00020540 EQUIVALENCE (HFRQ , DLOCAL (15)) 00020550 EQUIVALENCE (LFRQ , DLOCAL (16)) 00020560 EQUIVALENCE (ICO , DLOCAL (17)) 00020570 EQUIVALENCE (IDDATM , DLOCAL (18)) 00020580 EQUIVALENCE (IFLAG , DLOCAL (19)) 00020590 EQUIVALENCE (NTR , DLOCAL (20)) 00020600 EQUIVALENCE (IMEM , DLOCAL (21)) 00020610 EQUIVALENCE (IMEM1 , DLOCAL (22)) 00020620 EQUIVALENCE (IMEM2 , DLOCAL (23)) 00020630 EQUIVALENCE (IMEM3 , DLOCAL (24)) 00020640 EQUIVALENCE (IMEM4 , DLOCAL (25)) 00020650 EQUIVALENCE (ITYP , DLOCAL (26)) 00020660 EQUIVALENCE (IVDATM , DLOCAL (28)) 00020670 EQUIVALENCE (NEXP , DLOCAL (30)) 00020680 EQUIVALENCE (NFB , DLOCAL (31)) 00020690 EQUIVALENCE (NFCPB , DLOCAL (32)) 00020700 EQUIVALENCE (IDXST , DLOCAL (33)) 00020710 EQUIVALENCE (ISHL , DLOCAL (34)) 00020720 EQUIVALENCE (NOM , DLOCAL (35)) 00020730 EQUIVALENCE (NOMHI , DLOCAL (36)) 00020740 EQUIVALENCE (NOMLO , DLOCAL (37)) 00020750 EQUIVALENCE (NOUT(1) , DLOCAL (38)) 00020760 EQUIVALENCE (NS , DLOCAL (40)) 00020770 EQUIVALENCE (NSOUT , DLOCAL (41)) 00020780 EQUIVALENCE (NTB , DLOCAL (42)) 00020790 EQUIVALENCE (NTPB , DLOCAL (43)) 00020800 EQUIVALENCE (NT , DLOCAL (44)) 00020810 EQUIVALENCE (NTE , DLOCAL (45)) 00020820 EQUIVALENCE (NTT , DLOCAL (46)) 00020830 EQUIVALENCE (NUMT , DLOCAL (47)) 00020840 EQUIVALENCE (NX , DLOCAL (48)) 00020850 EQUIVALENCE (NZ , DLOCAL (49)) 00020860 EQUIVALENCE (NZB , DLOCAL (50)) 00020870 EQUIVALENCE (NZCPB , DLOCAL (51)) 00020880 EQUIVALENCE (NZF , DLOCAL (52)) 00020890 EQUIVALENCE (PSHOT(1) , DLOCAL (53)) 00020900 EQUIVALENCE (SCALE , DLOCAL (65)) 00020910 EQUIVALENCE (TCNT , DLOCAL (66)) 00020920 EQUIVALENCE (THL , DLOCAL (67)) 00020930 EQUIVALENCE (TNS , DLOCAL (68)) 00020940 EQUIVALENCE (VMAX , DLOCAL (69)) 00020950 C 00020960 EQUIVALENCE (ASHOT , DLOCAL (71)) 00020970 EQUIVALENCE (ATO100 , DLOCAL (72)) 00020980 EQUIVALENCE (IC , DLOCAL (73)) 00020990 EQUIVALENCE (IGRTIO , DLOCAL (74)) 00021000 EQUIVALENCE (IND , DLOCAL (75)) 00021010 EQUIVALENCE (IND31 , DLOCAL (76)) 00021020 EQUIVALENCE (IND33 , DLOCAL (77)) 00021030 EQUIVALENCE (IND35 , DLOCAL (78)) 00021040 EQUIVALENCE (IND36 , DLOCAL (79)) 00021050 EQUIVALENCE (IRCV , DLOCAL (80)) 00021060 EQUIVALENCE (ISHOT , DLOCAL (81)) 00021070 EQUIVALENCE (ISBDAT , DLOCAL (82)) 00021080 EQUIVALENCE (ISHT , DLOCAL (83)) 00021090 EQUIVALENCE (ISHTR , DLOCAL (84)) 00021100 EQUIVALENCE (ISHTS , DLOCAL (85)) 00021110 EQUIVALENCE (ISHT1 , DLOCAL (86)) 00021120 EQUIVALENCE (ISRTIO , DLOCAL (87)) 00021130 EQUIVALENCE (ISTOT , DLOCAL (88)) 00021140 EQUIVALENCE (ITOT , DLOCAL (89)) 00021150 EQUIVALENCE (I40 , DLOCAL (90)) 00021160 EQUIVALENCE (KTOT , DLOCAL (91)) 00021170 EQUIVALENCE (KTRAC , DLOCAL (92)) 00021180 EQUIVALENCE (LCHECK , DLOCAL (93)) 00021190 EQUIVALENCE (MTOT , DLOCAL (94)) 00021200 EQUIVALENCE (MXHR , DLOCAL (95)) 00021210 EQUIVALENCE (MXPTS , DLOCAL (96)) 00021220 EQUIVALENCE (MXSEG , DLOCAL (97)) 00021230 EQUIVALENCE (NSHOTS , DLOCAL (98)) 00021240 EQUIVALENCE (NTOT , DLOCAL (99)) 00021250 EQUIVALENCE (NTPS , DLOCAL(100)) 00021260 EQUIVALENCE (NUML , DLOCAL(101)) 00021270 EQUIVALENCE (NUMR , DLOCAL(102)) 00021280 EQUIVALENCE (NUMS , DLOCAL(103)) 00021290 EQUIVALENCE (POSL , DLOCAL(104)) 00021300 EQUIVALENCE (SHOTL , DLOCAL(105)) 00021310 EQUIVALENCE (SHOTP , DLOCAL(106)) 00021320 C 00021330 EQUIVALENCE (DAWRKR , DLOCAL(107)) 00021340 EQUIVALENCE (DAWRKW , DLOCAL(108)) 00021350 EQUIVALENCE (NUMLC , DLOCAL(109)) 00021360 EQUIVALENCE (NUMRC , DLOCAL(110)) 00021370 C 00021380 EQUIVALENCE (BDAM0 , DLOCAL(112)) 00021390 EQUIVALENCE (BDAM1 , DLOCAL(113)) 00021400 EQUIVALENCE (BDAM2 , DLOCAL(114)) 00021410 EQUIVALENCE (BDAM3 , DLOCAL(115)) 00021420 EQUIVALENCE (DAT1 , DLOCAL(116)) 00021430 EQUIVALENCE (DAT2M1 , DLOCAL(117)) 00021440 EQUIVALENCE (INTFLG , DLOCAL(118)) 00021450 EQUIVALENCE (ITRAC1 , DLOCAL(119)) 00021460 EQUIVALENCE (ITRACN , DLOCAL(120)) 00021470 EQUIVALENCE (NOM1 , DLOCAL(121)) 00021480 EQUIVALENCE (NOM2 , DLOCAL(122)) 00021490 EQUIVALENCE (TABST , DLOCAL(123)) 00021500 EQUIVALENCE (TABEND , DLOCAL(124)) 00021510 EQUIVALENCE (TRCBUF , DLOCAL(125)) 00021520 C 00021530 EQUIVALENCE (APINDX , DLOCAL(126)) 00021540 EQUIVALENCE (INDFFT , DLOCAL(127)) 00021550 EQUIVALENCE (APUNIT , DLOCAL(128)) 00021560 EQUIVALENCE (APFFTR , DLOCAL(129)) 00021570 EQUIVALENCE (CIT , DLOCAL(130)) 00021580 C 00021590 C INTEGER VARIABLES AND CONSTANTS--LOCAL 00021600 C 00021610 INTEGER IPAD / 0/ 00021611 INTEGER LLOCAL / 150/ 00021612 INTEGER R1 / 1 / 00021613 INTEGER R2 / 2 / 00021614 INTEGER URKWDS / 75000/ 00021615 INTEGER HRZ 00021620 INTEGER ID 00021630 INTEGER IM 00021640 INTEGER MAX 00021670 INTEGER PRM 00021680 INTEGER PTS 00021690 C 00021730 CHARACTER*8 DDNAM1 00021731 CHARACTER*8 DDNAM2 00021732 CHARACTER*8 DDNAM3 00021733 CHARACTER*8 DDNAM4 00021734 C 00021735 C 00021738 INTEGER CARRAY(6) /'HRZ ','D ','M ','MAX ', 00021739 1 'PRM ','PTS '/ 00021740 C 00021741 EQUIVALENCE (CARRAY(1), HRZ) 00021742 EQUIVALENCE (CARRAY(2), ID) 00021743 EQUIVALENCE (CARRAY(3), IM) 00021744 EQUIVALENCE (CARRAY(4), MAX) 00021745 EQUIVALENCE (CARRAY(5), PRM) 00021746 EQUIVALENCE (CARRAY(6), PTS) 00021747 C 00021748 IF ( KPFCF .EQ. 0 ) GO TO 100 00021749 C 00021750 C MAKE SURE THE INPUT IS A TRACE 00021760 C 00021770 CALL USRTHV ( INH, 'THTICD ', TICD ) 00021780 IF ( TICD .NE. 1 .AND. TICD .NE. 2 ) GO TO 830 00021790 C 00021800 C ==================================================================== 00021810 C INITIALIZATION 00021820 C ==================================================================== 00021830 C 00021840 KPFCF = 0 00021850 DAP = 1 00021860 C 00021870 C PRINT HEADING 00021880 C 00021890 CALL USPHD (2, ACLNAM,KPNA, KPRNO, 0, 0, KPPRNT) 00021900 C 00021910 C APPROXIMATE THE AMOUNT OF MEMORY REQUIRED FOR 00021920 C THIS PROCESS. 00021930 C 00021940 CALL USRTHV (INH, 'THL ', THL) 00021950 CALL USRTHV (INH, 'THNS ', NOSAMP) 00021960 NOWDS = LLOCAL 00021970 IMF = 1 00021980 CALL UPRESM (NOWDS) 00021990 IF (NOWDS .EQ. 0) GO TO 810 00022000 C 00022010 IDT = LCPI 00022020 DT = 0.001*FLOAT(IDT) 00022030 NUMT= LCRL/IDT 00022040 DX = LCGRPI 00022050 C 00022060 C ==================================================================== 00022070 C SET START OF DISK ADDRESSES OF WEIGHT TABLES 00022080 C ==================================================================== 00022090 C 00022100 IC = KPIUSM 00022110 TABST = IC 00022120 C 00022130 C READ ALL WEIGHT TABLES AND 00022140 C SAVE THEIR DISK ADDRESSES 00022150 C 00022160 IP = IC + 2 00022170 DAP = 1 00022180 C 00022190 10 CALL FORP(KPNA,KPRNO,DAP,104,DENTRY, *20 ) 00022200 C 00022210 IF(DCTYP.NE.PRM) GO TO 10 00022220 C 00022230 C SAVE THE DISK ADDRESS AND DEPTH POINT 00022240 C 00022250 IF(IP+1.GT.KPIUSM+KPNUSM) GO TO 810 00022260 COM(IP) = DAP - 1 00022270 COM(IP+1) = SPT 00022280 IP = IP + 2 00022290 GO TO 10 00022300 C 00022310 C SORT THE WEIGHT TABLES BY DEPTH POINT 00022320 C 00022330 20 IF(IP.EQ.IC+2) GO TO 840 00022340 C 00022350 IP = IP - 1 00022360 IPS = IC + 4 00022370 IF(IPS.GE.IP) GO TO 40 00022380 C 00022390 DO 30 I = IPS,IP,2 00022400 C 00022410 DO 30 K = IPS,IP,2 00022420 IF(COM(K-1).LT.COM(K+1)) GO TO 30 00022430 C 00022440 H1 = COM(K-2) 00022450 H2 = COM(K-1) 00022460 COM(K-2) = COM(K) 00022470 COM(K-1) = COM(K+1) 00022480 COM(K) = H1 00022490 COM(K+1) = H2 00022500 C 00022510 30 CONTINUE 00022520 C 00022530 C SET END ENTRIES 00022540 C 00022550 40 COM(IC) = COM(IC+2) 00022560 COM(IC+1) = -999999 00022570 COM(IP+1) = COM(IP-1) 00022580 COM(IP+2) = 999999999 00022590 TABEND = IP+2 00022600 IC = TABEND + 2 00022610 C 00022620 C ==================================================================== 00022630 C ACCUMULATE THE DEPTH POINT RANGES. 00022640 C ==================================================================== 00022650 C 00022660 DAT1 = IC 00022670 DAT2 = IC 00022680 COM(DAT1) = 999999999 00022690 DAP = 1 00022700 NRECS=0 00022710 C 00022720 C GET RANGES FROM SEISPARM FILE 00022730 C 00022740 50 CALL FORP(KPNA,KPRNO,DAP,104,DENTRY, *70 ) 00022750 C 00022760 IF(DCTYP.NE.PTS ) GO TO 50 00022770 C 00022780 C TRANSFER DATA INTO ARRAY COM 00022790 C 00022800 IF (IC+NOPAR.GT.KPIUSM+KPNUSM) GO TO 810 00022810 CALL ARMVE(DATTR,COM(IC),NOPAR) 00022820 C 00022830 DO 60 I=1,NOPAR,2 00022840 NRECS=MAX0(NRECS,IABS(DATTR(I+1)-DATTR(I))+1) 00022850 60 CONTINUE 00022860 C 00022870 IC = IC + NOPAR 00022880 DAT2 = IC - 1 00022890 GO TO 50 00022900 C 00022910 70 IC = DAT2 + 1 00022920 DAT2M1 = DAT2 -1 00022930 C 00022940 C SET UP SAVE BUFFER FOR SINGLE TRACE 00022950 C 00022960 TRCBUF= IC 00022970 IC = IC + NOSAMP + THL 00022980 C 00022990 NT = INT(NUMT*1.04) 00023000 CALL S1FMAG ( NT, NEXP, NTT ) 00023010 APINDX = KPIUSM + KPNUSM - NTT - 20 00023020 INDFFT = APINDX + 10 00023030 IX = INDFFT + NTT + 2 00023040 APLEN = IX - APINDX 00023050 APSIZE = 2 * APLEN - 10 00023060 C 00023070 CALL CSAPUN (APSIZE, APUNIT) 00023080 IF (APUNIT .EQ. 0) GO TO 75 00023090 CIT = IC 00023100 IC = IC + 50 00023110 C 00023120 C THESE CALLS SET UP A 3838 PROGRAM TO DO A FORWARD FFT 00023130 C 3838 ADDRESSES: 0 LENGTH OF FORWARD FFT 00023140 C 1 LENGTH OF RESULT 00023150 C 2-9 RESERVED FOR FUTURE USE 00023160 C 00023170 C 00023180 CALL VPSS (APUNIT, 'BLD ', 3, CCW, 20, COM(CIT ), 50) 00023190 C 00023200 CALL VPSS (APUNIT, 'VPUT', COM(APINDX), APLEN, 0, 0) 00023210 C 00023220 CALL VPSS (APUNIT, 'XMVS', 0, 2, 0, R1) 00023230 C 00023240 CALL VPSS (APUNIT, 'FFTR', 0, 00023250 * 96, 10, 0, R1, R2, 00023260 * 64, 10, 0, R1) 00023270 C 00023280 CALL VPSS (APUNIT, 'SMY ', 0, 00023290 * 64, 10, 2, 1, R1, 00023300 * 32, 10, 1, R1 , 00023310 * 0, 2 ) 00023320 C 00023330 CALL VPSS (APUNIT, 'VGET', COM(APINDX), APLEN, 0, 0) 00023340 C 00023350 CALL VPSS (APUNIT, 'XLTE', APFFTR) 00023360 C 00023370 75 NOWDS = IC - TABST 00023380 CALL UPRESM ( NOWDS ) 00023390 IF(NOWDS.EQ.0) GO TO 810 00023400 C 00023410 C ==================================================================== 00023420 C INITIALIZE TRACE SAVE FILE 00023430 C ==================================================================== 00023440 C 00023450 LEN0 = 4 * (NOSAMP+THL) 00023460 NRECS = NRECS*LCTPSP 00023470 CALL ARSET ( COM(KPIUSM), LEN0/4 , 0 ) 00023480 DAWRKW = 1 00023490 C 00023500 IF(KPBUGF.EQ.1) WRITE(KPPRNT, 9000 ) LEN0,NRECS,LCTPSP 00023510 C 00023520 CKG CALL UGAWRK (NRECS,LEN0,BSAM0 , BDAM0 , ERR, ERIN ) 00023530 C 00023531 CALL UPAWRK (NRECS,LEN0, 'A', BSAM0 , BDAM0 , DDNAM1, ERR, ERIN ) 00023532 IF(ERR.NE.1 ) GO TO 850 00023540 CALL FOISSD ( BSAM0 , LEN0 ) 00023550 DO 80 I=1,NRECS 00023590 CALL FOWSSD ( BSAM0 ,DAWRKW,COM(KPIUSM) ) 00023600 80 CONTINUE 00023630 C 00023640 CALL FOIDSD ( BDAM0 , LEN0 ) 00023650 C 00023680 C =================================================================== 00023690 C FINISH UP INITIALIZATION 00023700 C =================================================================== 00023710 C 00023720 90 NS = 0 00023730 TNS = 0 00023740 SCALE = 0.0 00023750 ICO = 0 00023760 VMAX = 0.0 00023770 IDXST = 0 00023780 SHOTL = -999999 00023790 POSL = -999999 00023800 SHOTP = -999999 00023810 ITRAC1= 999999 00023820 ITRACN= -999999 00023830 NUML = 0 00023840 NUMR = 0 00023850 NUMLC = 999999 00023860 NUMRC = -999999 00023870 NUMS = 0 00023880 C 00023890 INTFLG= 2 00023900 DAWRKR= 1 00023910 DAWRKW= 1 00023920 C 00023930 IF( KPBUGF .NE. 0)WRITE(KPPRNT, 9010 ) (COM(J),J=TABST,DAT2) 00023940 C 00023950 GO TO 120 00023960 C 00023970 C ==================================================================== 00023980 C SAVE THE DATA 00023990 C ==================================================================== 00024000 C 00024010 100 CALL ARMVE (COM(KPIRSM), DLOCAL, LLOCAL) 00024020 C 00024030 C CHECK FOR PASS 2 OR NO MORE INPUT 00024040 C 00024050 IF (KPMOTF .NE. 0) GO TO 650 00024060 IF (KPMITF .NE. 0) GO TO 120 00024070 C 00024080 110 IF (DAWRKR.GE.DAWRKW) GO TO 480 00024090 CALL FORDSD ( BDAM0 , DAWRKR, XCOM(TRCBUF) ) 00024100 GO TO 130 00024130 C 00024140 120 IF(KPBUGF .GT. 1)WRITE(KPPRNT, 9020 ) DLOCAL 00024150 C 00024160 CALL ARMVE ( INH, COM(TRCBUF), THL+NOSAMP ) 00024170 130 CALL USRTHV ( COM(TRCBUF), 'THSSP ', SHOTT ) 00024180 C 00024190 C CHECK IF WE RECEIVED A TRACE FROM A NEW 00024200 C DEPTH POINT. IF TRUE, WE NEED TO CHECK 00024210 C WHETHER OR NOT THIS CDP NEEDS TO BE 00024220 C PROCESSED. 00024230 C 00024240 IF(SHOTT.EQ.SHOTL) GO TO 390 00024250 C 00024260 C SELECTIVE PROCESSING, SEARCH THE DEPTH POINT 00024270 C TABLE IN COMMON FOR THE INPUT CDP NUMBER. 00024280 C 00024290 DO 140 I = DAT1,DAT2M1,INTFLG 00024300 IF(COM(I).LE.SHOTT.AND.SHOTT.LE.COM(I+1)) GO TO 150 00024310 C 00024320 140 CONTINUE 00024330 C 00024340 C CHANGE THE RETURN FLAG FROM 2 TO 0 WHEN 00024350 C THE TRACE WAS OUT OF RANGE 00024360 C 00024370 IF(KPBUGF.GE.2) WRITE (KPPRNT, 9030 ) SHOTT 00024380 C 00024390 GO TO 780 00024400 C 00024410 150 IF(KPMITF.EQ.0) GO TO 170 00024420 C 00024430 CALL USRTHV ( COM(TRCBUF), 'THRCLN ', IRC ) 00024440 CALL USRTHV ( COM(TRCBUF), 'THSLN ', ISH ) 00024450 C 00024460 ITRAC1 = MIN0(ITRAC1,ISH,IRC) 00024470 ITRACN = MAX0(ITRACN,ISH,IRC) 00024480 IF(SHOTP.EQ.SHOTT) GO TO 160 00024490 C NUMLC= 0 00024500 C NUMRC= 0 00024510 NUMS = NUMS+1 00024520 C 00024530 IF (SHOTP.NE.-999999) IDXST = IDXST + IABS(ISH-ISHL) 00024540 ISHL = ISH 00024550 C 00024560 160 SHOTP = SHOTT 00024570 C IF((IRC-ISH).GT.0) NUMRC= NUMRC+ 1 00024580 C IF((IRC-ISH).LT.0) NUMLC= NUMLC+ 1 00024590 C NUML = MAX0(NUML,NUMLC) 00024600 C NUMR = MAX0(NUMR,NUMRC) 00024610 IDIST= IRC - ISH 00024620 NUMLC= MIN0 ( NUMLC, IDIST ) 00024630 NUMRC= MAX0 ( NUMRC, IDIST ) 00024640 C 00024650 CALL FOWDSD ( BDAM0, DAWRKW, COM(TRCBUF) ) 00024660 GO TO 780 00024690 C 00024700 170 POS = COM(I) 00024710 C 00024720 C ==================================================================== 00024730 C IF THE CURRENT TRACE BELONGS TO A NEW 00024740 C SHOT POINT LOCATION, WE NEED TO CHECK 00024750 C WHETHER OR NOT THE STACKING TABLE NEEDS 00024760 C TO BE UPDATED. 00024770 C ==================================================================== 00024780 C 00024790 IF(POS.EQ.POSL) GO TO 390 00024800 IF(POSL.EQ.-999999)GO TO 180 00024810 C IF(MOD(ISTOT,NSHOTS).GT.0) GO TO 440 00024820 GO TO 470 00024830 C 00024840 C THE NEXT SECTION OF CODE RELOADS A NEW SET 00024850 C OF TABLES FROM THE DISK, SINCE THE CURRENT 00024860 C SHOT POINT IS OUTSIDE THE PREVIOUS RANGE 00024870 C 00024880 180 SHOTL=SHOTT 00024890 C 00024900 DO 190 I = TABST,TABEND,2 00024910 IF(COM(I+1).EQ.POS ) GO TO 200 00024920 C 00024930 190 CONTINUE 00024940 C 00024950 C READ IN WEIGHTING TABLES 00024960 C 00024970 200 DA = COM(I) 00024980 CALL FORP(KPNA,KPRNO,DA,104,DENTRY, *840 ) 00024990 C 00025000 IF (DCTYP.NE.PRM) GO TO 840 00025010 C 00025020 IFSP = DATTR(01) 00025030 ILSP = DATTR(02) 00025040 C ITRAC1 = 100 00025050 C ITRACN = 17500 00025060 DIP = ATTR(03) 00025070 LFRQ = ATTR(04) 00025080 HFRQ = ATTR(05) 00025090 ITYP = DATTR(06) 00025100 INZ = DATTR(07) 00025110 IDZ = ATTR(08) 00025120 IDDATM = ATTR(09) 00025130 C 00025140 NUML = DATTR(12) 00025150 NUMR = DATTR(13) 00025160 C IF(DATTR(14).NE.-99999) NUMS = DATTR(14) 00025170 IDXS = DATTR(10) 00025180 IDXT = DATTR(11) 00025190 IF(IDXT .NE.-99999) GO TO 205 00025200 C 00025210 IDXT = (IDXST/(NUMS-1))/100 00025220 IDXT = IDXS/IDXT 00025230 205 IDXST = IDXT 00025240 C 00025250 MXHR = DATTR(21) 00025260 MXSEG = DATTR(22) 00025270 MXPTS = DATTR(23) 00025280 C 00025290 NZ=INZ 00025300 DZ=IDZ 00025310 DX = LCGRPI 00025320 IDXR=DX 00025330 IDIP=DIP 00025340 C 00025350 IF ( NUML.EQ.-99999 ) NUML = -(NUMLC/100)*IDXST/IDXR 00025360 IF ( NUMR.EQ.-99999 ) NUMR = (NUMRC/100)*IDXST/IDXR 00025370 C 00025380 WRITE(KPPRNT, 9040 ) ITRAC1,ITRACN,DIP,LFRQ, 00025390 * HFRQ,ITYP,INZ,IDZ,IDDATM,NUML,NUMR,NUMS,IDXS,IDXST,MXHR, 00025400 *MXSEG,MXPTS 00025410 C 00025420 C ==================================================================== 00025430 C UPDATE POSITION;INITIALIZE FOR NEW GATHER RANGE 00025440 C ==================================================================== 00025450 C 00025460 210 POSL = POS 00025470 C 00025480 ISUM=0 00025490 CSAVE = 0 00025500 IOADR = 0 00025510 TCNT = 0 00025520 SCALE = 0.0 00025530 ICO = 0 00025540 VMAX = 0.0 00025550 DAWRK2= 1 00025560 TRACES= DAWRKW-1 00025570 C 00025580 CALL USRTHV(COM(TRCBUF), 'THSSP ', ISSP ) 00025590 CALL USRTHV(COM(TRCBUF), 'THRCLN ', IREC1) 00025600 CALL USRTHV(COM(TRCBUF), 'THSLN ',ISHT1) 00025610 CALL USRTHV(COM(TRCBUF), 'THCDPN ', ICDP1) 00025620 CALL USRTHV(COM(TRCBUF), 'THCDPL ',ICDPLQ) 00025630 CALL USRTHV(COM(TRCBUF), 'THCDPS ',IDXCDP) 00025640 C 00025650 ISHT2=ISHT1 00025660 CDPLQ = ICDPLQ/100. 00025670 C 00025680 C ==================================================================== 00025690 C 00025700 DXCDP=FLOAT(IDXCDP) 00025710 RTCDP=DXCDP/IDXST 00025720 NTPS1= NUMR + NUML + 1 00025730 IPAD = 0 00025740 C 00025750 NTPS = 2*IPAD + NTPS1 00025760 DXR = FLOAT(IDXR) 00025770 DXS = FLOAT(IDXS) 00025780 DXST = FLOAT(IDXST) 00025790 C 00025800 RTO = DXR/DXST 00025810 STO = DXS/DXST 00025820 DX = DXR 00025830 IDX=INT(DX) 00025840 ATO = RTO 00025850 ATO100 = ATO*100. 00025860 TRAC1 = ITRAC1 00025870 TRACN = ITRACN 00025880 C 00025890 ITRAC1 = INT(TRAC1/ATO100+SIGN(0.499,TRAC1)) 00025900 ITRACN = INT(TRACN/ATO100+SIGN(0.499,TRACN)) 00025910 C 00025920 ISRTIO = IDXS/DX 00025930 IF(ISRTIO.EQ.0) ISRTIO=1 00025940 IGRTIO = IDXR/IDXS 00025950 IF(IGRTIO.EQ.0) IGRTIO=1 00025960 NUMS = (NUMS-1)/IGRTIO + 1 00025970 NTOT = NUMS * NTPS 00025980 SHT1 = ISHT1 00025990 REC1 = IREC1 00026000 C 00026010 KTRAC = ITRAC1 - 1 00026020 ISHTR=INT(ISHT1/ATO100+SIGN(.499,SHT1))+(NUMS-1)*ISRTIO-KTRAC 00026030 ISHT1=INT(ISHT1/ATO100+SIGN(.499,SHT1)) - KTRAC 00026040 IV=ISHT1-INT(IREC1/ATO100+SIGN(.499,REC1)) + KTRAC 00026050 IF( IV .GT.NUML) IREC1 = IREC1+(IV-NUML)*ATO100 00026060 ISHOT = ISHT1 00026070 IRC1 = INT(IREC1/ATO100 - KTRAC +.5) 00026080 C 00026090 C IF(ISHT1.LT.(ITRAC1-KTRAC)) GO TO 20 00026100 C IF(ISHTR.GT.(ITRACN-KTRAC)) GO TO 20 00026110 C 00026120 ISTOT = 1 00026130 ITOT = ISHT1 00026140 LCHECK = 0 00026150 ISHTS = 1 00026160 MTOT = 0 00026170 KTOT = 0 00026180 ICHECK = 0 00026190 ISHT = 0 00026200 ASHOT = ISHT2*0.01 00026210 IRCV = IRC1-1 00026220 C 00026230 C =================================================================== 00026240 C 00026250 IFLAG = IM 00026260 IF(IDDATM.NE.0) IFLAG = ID 00026270 C 00026280 BETA = 0.101 00026290 ETA = C1+DIP*(C2+DIP*C3) 00026300 DIPC = C4+DIP*(C5+DIP*C6) 00026310 C 00026320 NX = ITRACN-ITRAC1+1 00026330 NTR= NUMS 00026340 C 00026350 ITYP1 = ITYP+1 00026360 GO TO ( 215 , 220 , 230 , 240 ), ITYP1 00026370 C 00026380 215 NTR = TRACES 00026390 GO TO 250 00026400 220 NSOUT = 1 00026410 NOUT(1) = 4 00026420 GO TO 250 00026430 230 NSOUT = 1 00026440 NOUT(1) = 1 00026450 GO TO 250 00026460 240 NSOUT = 2 00026470 NOUT(1) = 4 00026480 NOUT(2) = 1 00026490 NTR=NTR*2 00026500 C 00026510 250 NT = INT(NUMT*1.04) 00026520 IF(IFLAG.EQ.ID) NT=NUMT 00026530 CALL S1FMAG ( NT,NEXP,NTT ) 00026540 NTE = MAX0(NT,NTT) 00026550 C 00026560 DOM = C4/(NTT*DT) 00026570 NOMLO = INT(LFRQ/DOM)+1 00026580 C NOMHI = INT(HFRQ/DOM)+1 00026590 NOMHI = INT(HFRQ/DOM) 00026600 NOM = NOMHI - NOMLO + 1 00026610 C 00026620 DOM = DOM*TWOPI 00026630 C 00026640 C ================================================================== 00026650 C BUILD VELOCITY FIELD FROM INPUT HORIZON CARDS WITH PROPER DZ 00026660 C ================================================================== 00026670 C 00026680 IMEM1 = MXHR*(3*(MXPTS+1)+2*(MXSEG+NX))+MAX0(THL,2*(MXPTS 00026690 * +NX),6*MXPTS ) 00026700 IMF = 2 00026710 IF ( KPNUSM .LT. IMEM1) GO TO 810 00026720 C 00026730 XD = KPIUSM 00026740 ZD = XD + MXHR*MXPTS 00026750 VHR = ZD + MXHR*MXPTS 00026760 NG = VHR + MXHR*MXPTS 00026770 NU = NG + MXHR*MXSEG 00026780 ND = NU + MXHR*(MXSEG+1) 00026790 NW = ND + MXHR 00026800 Z = NW + MXHR 00026810 HVEL = Z + NX*MXHR 00026820 V = HVEL + NX*MXHR 00026830 C 00026840 IL = Z 00026850 IR = IL + MXHR 00026860 C 00026870 C A(3*MXPTS IN A SEG); B(3*MXPTS IN A SEG) 00026880 C 00026890 A = V 00026900 B = A + 3*MXPTS 00026910 C 00026920 C NXV,VNX, ETC. (MAX PTS IN A HORIZON) 00026930 C 00026940 NXV = V 00026950 VNX = NXV + MXPTS 00026960 VX = VNX + MXPTS 00026970 NNX = VX + NX 00026980 C 00026990 IHP = -999 00027000 ISP = -999 00027010 VMIN = 999999. 00027020 DAP = DA 00027030 C 00027040 C READ AND EDIT HRZ PARAMETER RECORDS 00027050 C 00027060 260 CALL FORP (KPNA, KPRNO, DAP, 104, DENTRY, *280 ) 00027070 IF (DCTYP .NE. HRZ) GO TO 280 00027080 C 00027090 N = NOPAR-8 00027100 IDX = 1 00027110 C 00027120 DO 270 I=1,N,5 00027130 C 00027140 IH = DATTR(IDX ) 00027150 IS = DATTR(IDX+1) 00027160 C 00027170 IF(IH.NE.IHP .OR. IS.NE.ISP) IXS=1 00027180 IF(IH.NE.IHP) IXH=1 00027190 C 00027200 C XD(IH,IXH)=ATTR(IDX+2) 00027210 C ZD(IH,IXH)=ATTR(IDX+3) 00027220 C VHR(IH,IXH)=ATTR(IDX+4) 00027230 C 00027240 XCOM(XD -1+(IXH-1)*MXHR+IH) = ATTR(IDX+2) 00027250 XCOM(ZD -1+(IXH-1)*MXHR+IH) = ATTR(IDX+3) 00027260 XCOM(VHR-1+(IXH-1)*MXHR+IH) = ATTR(IDX+4) 00027270 C 00027280 IF(ATTR(IDX+4).GT.0.0) 00027290 * VMIN = AMIN1(VMIN,ATTR(IDX+4)) 00027300 C 00027310 C IF(IXH.EQ.1 .AND. IXS.EQ.1) NU(IH,IXS) = INT(XD(IH,IXH)/DX)+1 00027320 C IF(IS.EQ.1 .AND. IXS.EQ.3 .AND. XD(IH,IS).NE.0.0) 00027330 C * NU(IH,IS)= NU(IH,IS)+1 00027340 C NU(IH,IS+1) = INT(XD(IH,IXH)/DX) + 1 00027350 C 00027360 IF(IXH.EQ.1 .AND. IXS.EQ.1)COM(NU-1+(IXS-1)*MXHR+IH)=INT 00027370 * (ATTR(IDX+2)/DX)+1 00027380 IF(IS.EQ.1 .AND. IXS.GE.3 .AND. XCOM(XD-1+(IS-1)*MXHR+IH 00027390 * ).NE.0.0)COM(NU-1+(IS-1)*MXHR+IH) = COM(NU-1+(IS-1)*MXHR 00027400 * +IH)+1 00027410 COM(NU-1+IS*MXHR+IH) = INT(ATTR(IDX+2)/DX) + 1 00027420 C 00027430 C NW(IH) = IS 00027440 C ND(IH) = IXH 00027450 C NG(IH,IS)= IXS 00027460 C 00027470 COM(NW-1+IH) = IS 00027480 COM(ND-1+IH) = IXH 00027490 COM(NG-1+(IS-1)*MXHR+IH) = IXS 00027500 C 00027510 IDX = IDX + 5 00027520 IXH = IXH + 1 00027530 IXS = IXS + 1 00027540 IHP = IH 00027550 ISP = IS 00027560 C 00027570 270 CONTINUE 00027580 C 00027590 GO TO 260 00027600 C 00027610 280 IF(DZ.GT.0.) GO TO 290 00027620 VMIN=AMAX1(VMIN,4500.) 00027630 C IDZ=INT(0.25*VMIN/(HFRQ*DIPC)) 00027640 C DZ =IDZ 00027650 DZ= 0.25*VMIN/(HFRQ*DIPC) 00027660 IDZ= DZ 00027670 C 00027680 290 T = NUMT*DT 00027690 C 00027700 IF ( KPBUGF.EQ.0 ) GO TO 299 00027710 C 00027720 WRITE ( KPPRNT, 9300 ) 00027730 DO 298 I=1,MXHR 00027740 WRITE ( KPPRNT, 9310 ) 00027750 NY = COM(NW-1+I)+1 00027760 NUMF = COM(ND-1+I) 00027770 DO 294 J=1,NY 00027780 INC = J 00027790 IF(J .EQ.NY) INC = NY-1 00027800 ING = COM(NG-1+(INC-1)*MXHR+I) 00027810 INW = COM(NW-1+ I) 00027820 INU = COM(NU-1+( J -1)*MXHR+I) 00027830 WRITE ( KPPRNT, 9320 ) I,INC,ING,INW,INU,NUMF 00027840 294 CONTINUE 00027850 298 CONTINUE 00027860 C 00027870 299 IF(IFLAG.EQ.ID) GO TO 300 00027880 C 00027890 CALL SAZM02(DX,DZ,IFLAG,COM(IL),COM(IR),MXHR,COM(ND),NX,NZ 00027900 *,NZF,T,XCOM(VHR),XCOM(XD),XCOM(ZD)) 00027910 C 00027920 NZF = MIN0(NZF,NUMT) 00027930 GO TO 310 00027940 C 00027950 300 ANZ = FLOAT(IDDATM)/DZ 00027960 INZ = INT(ANZ) 00027970 NZF = INZ + (ANZ-INZ) + 0.9999 00027980 NZ = MAX0(NZ,INZ+2 ) 00027990 C 00028000 C ==================================================================== 00028010 C SET UP DATA BLOCKING FACTORS IN FREQUENCY AND DISTANCE 00028020 C PREPARE TO ALLOCATE AND OPEN WORKFILES WITH CORRECT DCBS 00028030 C ==================================================================== 00028040 C 00028050 310 NSHOTS = MAX0(192/NTPS,1) 00028060 NTPB = NTPS*NSHOTS 00028070 C NTB = (NTOT-1)/NTPB +1 00028080 NTB = (NUMS-1)/NSHOTS+1 00028090 NFCPB = 8000/NTPB 00028100 NFCPB = MIN0(NFCPB,50000/(NTPB*NTB)) 00028110 NFB = (NOM-1)/NFCPB+1 00028120 NOM1 = NFCPB*NFB 00028130 NOM2 = NOM1*2 00028140 JWRK = NTPB*NOM2 00028150 C 00028160 320 WRITE (KPPRNT, 9050 ) DZ,NZ,NZF 00028170 C 00028180 C INITIALIZE WORKFILE 1 - VELOCITY INFORMATION 00028190 C 00028200 LEN = MAX0(NX,THL) 00028210 C LEN = MAX0(NX,THL,NUMS), BUT NUMS <= NX 00028220 LEN = LEN*4 00028230 CALL ARSET ( COM(V), LEN/4 , 0 ) 00028240 DAWRK = 1 00028250 NL = NUMS 00028260 IF(IFLAG.EQ.ID) NL = TRACES 00028270 NRECS = 4 * NZ + NL 00028280 C 00028290 IF(KPBUGF.EQ.1) WRITE(KPPRNT, 9060 ) LEN,NZ,NX,NRECS 00028300 C 00028310 CKG CALL UGAWRK (NRECS,LEN, BSAM1 , BDAM1 , ERR, ERIN ) 00028320 C 00028321 CALL UPAWRK (NRECS,LEN, 'B', BSAM1 , BDAM1 , DDNAM2, ERR, ERIN ) 00028322 IF(ERR.NE.1 ) GO TO 850 00028330 CALL FOISSD ( BSAM1 , LEN ) 00028340 C 00028370 DO 330 I=1,NRECS 00028380 CALL FOWSSD ( BSAM1 , DAWRK, COM(V) ) 00028390 330 CONTINUE 00028420 C 00028430 CALL FOIDSD ( BDAM1 , LEN ) 00028440 C 00028470 C BUILD VELOCITY FILE IN FIRST PARTITION OF DATA FILE 1 00028480 C 00028490 IOINC = 4 00028500 C 00028510 CALL SAZM03 ( XCOM(A), XCOM(B), DX, DZ, XCOM(HVEL), IER, IOINC, 00028520 *KPPRNT, BDAM1, MXHR, MXPTS, COM(ND), COM(NG), COM(NNX),COM( 00028530 *NU),COM(NW), NX, COM(NXV), NZ, XCOM(V),XCOM(VHR), XCOM(VNX 00028540 *),XCOM(VX), XCOM(XD),XCOM(Z), XCOM(ZD) ) 00028550 C 00028560 IF(IER.NE.0) GO TO 820 00028570 C 00028580 DAWRK = 4*NZ + 1 00028590 NL = NZF 00028600 IF(IFLAG.EQ.ID) NL=NUMT 00028610 C 00028620 IMEM2 = MAX0(NFCPB*NTPB,NL) 00028630 IMF = 3 00028640 IF(KPNUSM.LT.IMEM2) GO TO 810 00028650 C 00028660 C ----------------INITIALIZE WORKFILE 2--TRANSFORMS------------------- 00028670 C 00028680 LEN2 = 4 * NFCPB*NTPB 00028690 NRECS = 2 * NFB * NTB 00028700 CALL ARSET ( COM(XD), NFCPB*NTPB , 0 ) 00028710 DAWRK2 = 1 00028720 C 00028730 IF(KPBUGF.EQ.1) WRITE(KPPRNT, 9070 ) LEN2,NFCPB,NTPB,NFB,N 00028740 *TB,NRECS 00028750 C 00028760 CKG CALL UGAWRK (NRECS,LEN2,BSAM2 , BDAM2 , ERR, ERIN ) 00028770 C 00028771 CALL UPAWRK (NRECS,LEN2,'C', BSAM2 , BDAM2 , DDNAM3, ERR, ERIN ) 00028772 IF(ERR.NE.1 ) GO TO 850 00028780 CALL FOISSD ( BSAM2 , LEN2 ) 00028790 C 00028820 DO 340 I=1,NRECS 00028830 CALL FOWSSD ( BSAM2 ,DAWRK2,COM(XD) ) 00028840 340 CONTINUE 00028870 C 00028880 CALL FOIDSD ( BDAM2 , LEN2 ) 00028890 C 00028920 DAWRK2 = 1 00028930 C 00028940 C ----------------INITIALIZE WORKFILE 3--OUT DATA FILE----------------- 00028950 C 00028960 IF(IFLAG.EQ.ID) GO TO 350 00028970 C 00028980 IMF = 4 00028990 IMEM0 = 8*NX + NZ + NOM + NX*NUMS 00029000 IMEM1 = 6*NX 00029010 IMEM2 = NX*34 + 2*NFCPB*NTPB + 2*NFCPB*NTOT 00029020 IMEM3 = NFCPB*NTPB*(1 +2*NFB) + 2*NTT 00029030 IMEM = IMEM0 + MAX0(IMEM1,IMEM2,IMEM3) 00029040 IF (KPNUSM.LT.IMEM) GO TO 810 00029050 C IMEM = MAX0(IMEM,URKWDS) 00029060 C 00029070 IMF = 5 00029080 C NZCPB = MIN0((IMEM/2)/NX,NZF+1) 00029090 NZCPB = NZF + 1 00029100 NZB = NZF/NZCPB + 1 00029110 IMEM0 = NZCPB*NUMS 00029120 IMEM = MAX0(IMEM,IMEM0) 00029130 IF (KPNUSM.LT.IMEM) GO TO 810 00029140 C 00029150 LEN3 = NZCPB*4 00029160 NRECS = NZB*NUMS*NSOUT 00029170 GO TO 360 00029180 C 00029190 350 LEN3 = 4*NUMT 00029200 NRECS = NTOT 00029210 C 00029220 360 CALL ARSET( COM(XD), LEN3/4, 0 ) 00029230 DAWRK3 = 1 00029240 C 00029250 CKG CALL UGAWRK (NRECS,LEN3,BSAM3 , BDAM3 , ERR, ERIN ) 00029260 C 00029261 CALL UPAWRK (NRECS,LEN3,'D', BSAM3 , BDAM3 , DDNAM4, ERR, ERIN ) 00029262 IF(ERR.NE.1 ) GO TO 850 00029270 CALL FOISSD ( BSAM3 , LEN3 ) 00029280 C 00029310 DO 370 I=1,NRECS 00029320 CALL FOWSSD ( BSAM3 ,DAWRK3,COM(XD) ) 00029330 370 CONTINUE 00029360 C 00029370 CALL FOIDSD ( BDAM3 , LEN3 ) 00029380 C 00029410 C ==================================================================== 00029420 C SET UP RESERVED WORK AREAS 00029430 C ==================================================================== 00029440 C 00029450 IC = KPIUSM 00029460 IND31 = IC 00029470 ICC = IC + NX 00029480 IND35 = ICC 00029490 ICC = ICC+ NX 00029500 IND36 = ICC 00029510 ICC = ICC+ NX 00029520 IND41 = ICC 00029530 ICC = ICC+ NUMS 00029540 IND33 = ICC 00029550 ICC = ICC+ JWRK 00029560 IC = ICC 00029570 C 00029580 IF (IC .GT.KPIUSM+KPNUSM) GO TO 810 00029590 C 00029600 380 CALL ARSET ( XCOM(IND31),NX,-10000.) 00029610 CALL ARSET ( XCOM(IND33),JWRK, 0 ) 00029620 C 00029630 IND = IND33 - NOM2 00029640 I40 = IND41 00029650 XCOM(IND31+ISHT1 -1) = IRC1 00029660 XCOM(I40) = FLOAT(ISSP) 00029670 XCOM(IND36+ISHT1-1)=XCOM(IND31+ISHT1-1)-(ISHT1-NUML) 00029680 C 00029690 IF(KPBUGF .EQ. 1)WRITE(KPPRNT, 9020 ) DLOCAL 00029700 C 00029710 C ==================================================================== 00029720 C END OF INITIALIZATION STEP 00029730 C ==================================================================== 00029740 C ==================================================================== 00029750 C RETRIEVE THE LINE LOCATION NUMBER FROM TRACE HEADER FOR 00029760 C THIS TRACE AND CALCULATE ITS GRID POSITION 00029770 C ==================================================================== 00029780 C 00029790 390 CALL USRTHV(COM(TRCBUF),'THRCLN ',IRC) 00029800 IRC=INT(IRC/ATO100+ SIGN(.499,FLOAT(IRC)))-KTRAC 00029810 CALL USRTHV(COM(TRCBUF),'THSLN ',ISHI) 00029820 CALL USRTHV(COM(TRCBUF),'THSSP ',ISSP ) 00029830 SSP = FLOAT(ISSP) 00029840 SHOT = ISHI*0.01 00029850 ISHI = INT(ISHI/ATO100+SIGN(.499,FLOAT(ISHI)))-KTRAC 00029860 C 00029870 C IF(KPBUGF.GT.0) WRITE(KPPRNT,3434) IRC,ISHI,ISSP 00029880 C 00029890 IF(ASHOT.EQ.SHOT) GO TO 400 00029900 ASHOT=SHOT 00029910 ITOT =ITOT + 1 00029920 C 00029930 400 IF(IGRTIO.LE.1) GO TO 410 00029940 C 00029950 C TEST TO SEE WHETHER OR NOT THIS SHOT IS TO BE SKIPPED 00029960 C 00029970 AREAL =FLOAT(ITOT-ISHT1)/FLOAT(IGRTIO) 00029980 INTEG =(ITOT-ISHT1)/IGRTIO 00029990 ATEST = AREAL-INTEG 00030000 IF(ATEST.GT.(.01)) GO TO 110 00030010 C 00030020 C THROW AWAY PHONES OUTSIDE OF WHAT WAS SPECIFIED IN DATA CARD 00030030 C LCHECK COUNTS # OF PHONES/SHOT 00030040 C 00030050 410 IF(((ISHI-IRC).LE.NUML) .AND.((IRC-ISHI).LE.NUMR)) GO TO 420 00030060 GO TO 110 00030070 C 00030080 420 LCHECK=LCHECK+1 00030090 C 00030100 IF(ISHI.NE.ISHT1) GO TO 430 00030110 C IF(ISHI-IRC.LE.NUML .AND. IRC.LT.ITRAC1-KTRAC) GO TO ERROR 00030120 430 IF(ISHI.NE.ISHTR) GO TO 440 00030130 C IF(IRC-ISHI.LE.NUMR .AND. IRC.GT.ITRACN-KTRAC) GO TO ERROR 00030140 C 00030150 440 IRCV1 =IRCV 00030160 ISHTL = ISHT 00030170 C 00030180 C GET SHOT AND RECIEVER LOCATIONS FORT THIS TRACE. CHECK TO SEE 00030190 C IF THERE IS A MISSING SHOT OR RECIEVER. 00030200 C 00030210 IRCV=IRC 00030220 ISHT=ISHI 00030230 C 00030240 IND =IND + NOM2 00030250 IST = ISHT - ISHOT 00030260 IRCV2 = IRCV - IRCV1 00030270 C 00030280 C CHECK FOR SKIPPED SHOT...IF SKIPPED USE LINEAR INTERPOLATION 00030290 C 00030300 IF(IST.LE.ISRTIO) GO TO 460 00030310 IND = IND + (IST -(IST-2)/ISRTIO) * NTPS * NOM2 00030320 C 00030330 IST1 = ISHOT + ISRTIO 00030340 IST2 = ISHT - ISRTIO 00030350 C 00030360 DO 450 JT = IST1,IST2,ISRTIO 00030370 JX= JT + IND31 -1 00030380 JY= JT + IND35 -1 00030390 XCOM(JX) = XCOM(IST1+IND31-1) 00030400 450 XCOM(JY) = XCOM(IST1+IND35-1) 00030410 C 00030420 460 IF(ISHT.EQ.ISHOT) GO TO 570 00030430 C 00030440 IRCV2 = 1 00030450 XCOM(IND31-1+ISHT) = IRCV 00030460 XCOM(IND36+ISHT-1) = IRCV -( ISHT-NUML) 00030470 ISHOT = ISHT 00030480 ISTOT = ISTOT + 1 00030490 I40 = I40 +1 00030500 XCOM(I40) = FLOAT(ISSP) 00030510 IF(ISTOT.LE.NSHOTS) GO TO 560 00030520 GO TO 520 00030530 C 00030540 C ================================================================== 00030550 C THE LAST TRACE HAS BEEN ENCOUNTERED.DUMP WORK AREA. 00030560 C ================================================================== 00030570 C 00030580 470 W = INDFFT 00030590 C 00030600 IF(KPBUGF.GT.0) WRITE(KPPRNT, 9080 ) IRC,ISHI,ISSP,DAWRK 00030610 C 00030620 IF(APINDX.LT.IC ) GO TO 810 00030630 C 00030640 472 CALL ARSET(XCOM(W+NUMT),NTE-NUMT,0) 00030650 CALL ARMVE(COM(TRCBUF+THL),XCOM(W),NUMT) 00030660 C 00030670 IF ( APUNIT.EQ. 0 ) GO TO 475 00030680 KPRTF = 0 00030690 COM ( APINDX ) = NTT 00030700 COM (APINDX+1) = NTT/2 + 1 00030710 XCOM(APINDX+2) = 0.5 00030720 CALL VPSS (APUNIT, 'EXCW', APFFTR ) 00030730 IF ( KPRTF .LT. 0 ) GO TO 472 00030740 GO TO 476 00030750 C 00030760 475 SCAL = SQRT ( 0.5*NTT ) 00030770 CALL S2DFT2 ( NEXP, COM(INDFFT), *900 ) 00030780 CALL ARMPFC ( XCOM(INDFFT), XCOM(INDFFT), SCAL, NTT+2 ) 00030790 C 00030800 476 DO 477 I = 1, NOM 00030810 J = (NOMLO-2+I)*2 00030820 XCOM(IND +I-1) = XCOM(INDFFT + J ) 00030830 477 XCOM(IND+NOM1+I-1) = XCOM(INDFFT + J+1 ) 00030840 C 00030850 480 N=NTPS*ISTOT 00030860 IF(IC+NFCPB*N.GT.KPIUSM+KPNUSM) GO TO 810 00030870 C 00030880 490 ADDR1=0 00030890 NF=2*NFB 00030900 WBUF=IND33 00030910 C 00030920 DO 510 I=1,NF 00030930 ADDR2=ADDR1 00030940 RECL=IC 00030950 C 00030960 DO 500 J=1,N 00030970 CALL ARMVE(XCOM(ADDR2+WBUF),XCOM(RECL),NFCPB) 00030980 ADDR2=ADDR2+2*NFB*NFCPB 00030990 500 RECL =RECL+NFCPB 00031000 C 00031010 ADDR1 = ADDR1+NFCPB 00031020 C 00031030 CALL FOWDSD(BDAM2,DAWRK2,XCOM(IC ) ) 00031040 510 CONTINUE 00031070 C 00031080 XCOM(IND35-1+ISHT)= LCHECK + IPAD*2 00031090 IF(IFLAG.EQ.ID) NTR = MTOT 00031100 C 00031110 GO TO 580 00031120 C 00031130 C ==================================================================== 00031140 C THIS CSG WILL NOT FIT SO TRANSPOSE WORK AREA AFTER PADDING 00031150 C CSG AND THEN WRITE TO DISC. 00031160 C ===================================================================== 00031170 C 00031180 520 ISHTS = 1 00031190 ISTOT = 1 00031200 C 00031210 IF(KPBUGF.GT.0) WRITE(KPPRNT, 9090 ) IRC,ISHI,ISSP,DAWRK2 00031220 C 00031230 XCOM(IND35+ISHT-(ISRTIO+1))= LCHECK + IPAD*2 -1 00031240 LCHECK=1 00031250 C 00031260 N=NTPB 00031270 IF(IC+NFCPB*N.GT.KPIUSM+KPNUSM) GO TO 810 00031280 C 00031290 530 ADDR1=0 00031300 NF=2*NFB 00031310 WBUF=IND33 00031320 C 00031330 DO 550 I=1,NF 00031340 ADDR2=ADDR1 00031350 RECL=IC 00031360 C 00031370 DO 540 J=1,N 00031380 CALL ARMVE(XCOM(ADDR2+WBUF),XCOM(RECL),NFCPB) 00031390 ADDR2=ADDR2+2*NFB*NFCPB 00031400 540 RECL =RECL+NFCPB 00031410 C 00031420 ADDR1 = ADDR1+NFCPB 00031430 C 00031440 CALL FOWDSD(BDAM2,DAWRK2,XCOM(IC ) ) 00031450 550 CONTINUE 00031480 C 00031490 KTOT=0 00031500 IND=IND33 00031510 CALL ARSET(XCOM(IND33),JWRK, 0) 00031520 C 00031530 GO TO 570 00031540 C 00031550 C ==================================================================== 00031560 C DIFFERENT CSG WITHIN SAME WORK AREA 00031570 C ==================================================================== 00031580 C 00031590 560 XCOM(IND35+ISHT-(ISRTIO+1)) = LCHECK + 2*IPAD -1 00031600 IAD = (ISHTL +NUMR -IRCV1 ) *NOM2 00031610 IND = IND + 4*IPAD*NOM+IAD+(XCOM(IND36-1+ISHT) *NOM2 ) 00031620 C 00031630 IF(IFLAG.NE.ID) GO TO 565 00031640 IOADR = IOADR + ISHTL + NUMR - IRCV1 00031650 IOADR = IOADR + INT(XCOM(IND36-1+ISHT)+1.001) 00031660 CALL USSTHV ( COM(TRCBUF), 'THORTN ', IOADR ) 00031670 C 00031680 565 CALL FOWDSD(BDAM1,DAWRK,COM(TRCBUF) ) 00031690 IF(KPBUGF.GT.0) WRITE(KPPRNT, 9100 ) IRC,ISHI,ISSP,DAWRK,IOADR 00031720 C 00031730 W = INDFFT 00031740 IF(APINDX.LT.IC ) GO TO 810 00031750 C 00031760 566 CALL ARSET(XCOM(W+NUMT),NTE-NUMT,0) 00031770 CALL ARMVE(COM(TRCBUF+THL),XCOM(W),NUMT) 00031780 C 00031790 IF ( APUNIT.EQ. 0 ) GO TO 567 00031800 KPRTF = 0 00031810 COM ( APINDX ) = NTT 00031820 COM (APINDX+1) = NTT/2 + 1 00031830 XCOM(APINDX+2) = 0.5 00031840 CALL VPSS (APUNIT, 'EXCW', APFFTR ) 00031850 IF ( KPRTF.LT.0 ) GO TO 566 00031860 GO TO 568 00031870 C 00031880 567 SCAL = SQRT ( 0.5*NTT ) 00031890 CALL S2DFT2 ( NEXP, COM(INDFFT), *900 ) 00031900 CALL ARMPFC ( XCOM(INDFFT), XCOM(INDFFT), SCAL, NTT+2 ) 00031910 C 00031920 568 DO 569 I = 1, NOM 00031930 J = (NOMLO-2+I)*2 00031940 XCOM(IND +I-1 ) = XCOM(INDFFT + J ) 00031950 569 XCOM(IND+NOM1+I-1 ) = XCOM(INDFFT + J+1 ) 00031960 C 00031970 KTOT=KTOT+1 00031980 MTOT=MTOT+1 00031990 LCHECK = 1 00032000 C 00032010 GO TO 110 00032020 C 00032030 C ================================================================== 00032040 C SAME CSG OR NEW WORK AREA 00032050 C ================================================================== 00032060 C 00032070 570 IF(ISHTS.EQ.1) IND=IND+2*IPAD*NOM +(XCOM(IND36-1+ISHT)*NOM2 ) 00032080 C 00032090 IF(IFLAG.NE.ID) GO TO 573 00032100 IF(ISHTS.EQ.1 ) IOADR = IOADR + INT(XCOM(IND36-1+ISHT)+0.001) 00032110 IOADR = IOADR + IRCV2 00032120 CALL USSTHV ( COM(TRCBUF), 'THORTN', IOADR ) 00032130 GO TO 574 00032140 C 00032150 573 IF(ISHTS.NE.1) GO TO 575 00032160 C 00032170 574 CALL FOWDSD ( BDAM1, DAWRK, COM(TRCBUF) ) 00032180 C 00032210 575 IND =IND +(IRCV2-1)*NOM2 00032220 LCHECK = LCHECK +IRCV2-1 00032230 C 00032240 IF(KPBUGF.GT.0) WRITE(KPPRNT, 9110) IRC,ISHI,ISSP,DAWRK,IOADR, 00032250 * ISHTS 00032260 C 00032270 W = INDFFT 00032280 IF(APINDX.LT.IC ) GO TO 810 00032290 C 00032300 576 CALL ARSET(XCOM(W+NUMT),NTE-NUMT,0) 00032310 CALL ARMVE(COM(TRCBUF+THL),XCOM(W),NUMT) 00032320 C 00032330 IF ( APUNIT.EQ. 0 ) GO TO 577 00032340 KPRTF = 0 00032350 COM ( APINDX ) = NTT 00032360 COM (APINDX+1) = NTT/2 + 1 00032370 XCOM(APINDX+2) = 0.5 00032380 CALL VPSS (APUNIT, 'EXCW', APFFTR ) 00032390 IF ( KPRTF.LT.0 ) GO TO 576 00032400 GO TO 578 00032410 C 00032420 577 SCAL = SQRT ( 0.5*NTT ) 00032430 CALL S2DFT2 ( NEXP, COM(INDFFT), *900 ) 00032440 CALL ARMPFC ( XCOM(INDFFT), XCOM(INDFFT), SCAL, NTT+2 ) 00032450 C 00032460 578 DO 579 I = 1, NOM 00032470 J = (NOMLO-2+I)*2 00032480 XCOM(IND +I-1) = XCOM(INDFFT + J ) 00032490 579 XCOM(IND+NOM1+I-1) = XCOM(INDFFT + J+1 ) 00032500 C 00032510 KTOT=KTOT+1 00032520 MTOT=MTOT+1 00032530 ISHTS =0 00032540 C 00032550 GO TO 110 00032560 C 00032570 C ==================================================================== 00032580 C MAIN PROCESSING LOOP-PERFORM MIGRATION 00032590 C ==================================================================== 00032600 C 00032610 580 CONTINUE 00032620 C 00032630 IMF = 6 00032640 KPMOTF= 1 00032650 C 00032660 IMEM0 = 8*NX + NZ + NOM + NX*NUMS 00032670 IMEM1 = 6*NX 00032680 IMEM2 = NX*34 + 2*NFCPB*NTPB + 2*NFCPB*NTOT 00032690 IMEM3 = NFCPB*NTPB*(1 +2*NFB) + 2*NTT 00032700 IMEM = IMEM0 + MAX0(IMEM1,IMEM2,IMEM3) 00032710 IF ( IND33+IMEM.GT.KPIUSM+KPNUSM) GO TO 810 00032720 C 00032730 IDT = IND33 00032740 IVCHK = IDT + 8*NX 00032750 NOMCHK = IVCHK + NZ 00032760 LOCATS = NOMCHK + NOM 00032770 ISTO = LOCATS + NX*NUMS 00032780 IVEL = ISTO + NX 00032790 IXTO = IVEL + 3*NX 00032800 ITIM = IXTO + NX 00032810 C ITIM + NX 00032820 C 00032830 CALL SAZM13 (BETA,DOM,DT,DX,DZ,ETA,HFRQ,LFRQ,XCOM(IND35),I 00032840 *DDATM,COM(IDT),IFLAG,IPAD,KPPRNT,ISBDAT,ISHTR,ISHT1,ISRTIO 00032850 *,COM(ISTO),COM(IXTO),COM(IVCHK),BDAM1,BDAM2,BDAM3,COM(LOCA 00032860 *TS),NEXP,NFB,NFCPB,NOM,COM(NOMCHK),NOMHI,NOMLO,NT,NTB,NTOT 00032870 *,NTPB,NTPS,NTT,NX,NZ,NZF,XCOM(IND31),Q1,Q2,XCOM(ITIM),XCOM 00032880 *(IND36),XCOM(IVEL),VMAX) 00032890 C 00032900 IF(IFLAG.NE.IM) GO TO 640 00032910 C 00032920 C -----RESORT DEPTH SECTION AND VELOCITY FIELD FOR DISPLAY----- 00032930 C 00032940 590 IMEM5 = NUMS*NZF 00032950 IMF = 7 00032960 IF(KPNUSM.LT.IMEM5) GO TO 810 00032970 C 00032980 DIP = 1.0 00032990 DIPC= 0.0 00033000 DAWRK3= 1 00033010 C 00033020 DO 630 M=1,NSOUT 00033030 DAWRK=NOUT(M) 00033040 IND = IND35 00033050 K = IND31 00033060 C 00033070 DO 610 I=1,NZF 00033080 IX = IND 00033090 CALL FORDSD(BDAM1,DAWRK,XCOM(K ) ) 00033100 C 00033110 DO 600 J=ISHT1,ISHTR,ISRTIO 00033120 XCOM(IX ) = XCOM(K+J-1) 00033130 600 IX = IX + NZF 00033140 C 00033150 DAWRK=DAWRK+3 00033160 610 IND = IND + 1 00033170 C 00033180 K = IND35 00033190 C 00033200 DO 620 I=1,NUMS 00033210 CALL FOWDSD(BDAM3,DAWRK3,XCOM(K) ) 00033220 620 K = K+NZF 00033230 C 00033240 630 CONTINUE 00033250 C 00033260 C -----------------BEGIN TRACES OUTPUT OPERATIONS-------------------- 00033270 C 00033280 640 DAWRK = 1 00033290 C 00033300 C ------------PASS TRACES IN OUTPUT SECTIONS ONE BY ONE-------------- 00033310 C 00033320 650 XD = KPIUSM 00033330 CSAVE = CSAVE + 1 00033340 C 00033350 IF(CSAVE.GT.NTR) GO TO 770 00033360 IF(IFLAG.EQ.ID) GO TO 730 00033370 C 00033380 C =================================================================== 00033390 C OUTPUT DEPTH SECTION AND VELOCITY FIELD 00033400 C =================================================================== 00033410 C 00033420 IMEM5 = MAX0(NZF,NUMT,NX,THL) 00033430 IMF = 8 00033440 IF(KPNUSM.LT.IMEM5) GO TO 810 00033450 C 00033460 CALL FORDSD(BDAM3,DAWRK,XCOM(XD) ) 00033470 C 00033480 IF(CSAVE.GT.NUMS) GO TO 700 00033490 C 00033500 GO TO ( 720 , 700 , 670 ), ITYP 00033510 C 00033520 670 IF(MOD(CSAVE,NUMS/10).NE.1) GO TO 690 00033530 SCAL = 0.0 00033540 C 00033550 DO 680 I=1,NZF 00033560 680 SCAL=AMAX1(XCOM(KPIUSM+I-1),SCAL) 00033570 C 00033580 SCALE=SCALE+SCAL 00033590 ICO=ICO+1 00033600 C 00033610 690 IF(CSAVE.NE.NUMS) GO TO 720 00033620 SCALE=(SCALE/FLOAT(ICO)) * 1.5 00033630 DIP = SCALE/(VMAX+1.) 00033640 DIPC = SCALE*0.01 00033650 GO TO 720 00033660 C 00033670 700 XD=KPIUSM-1 00033680 C 00033690 DO 710 I=1,NZF 00033700 710 XCOM(XD+I)=DIP*(XCOM(XD+I+1)-XCOM(XD+I)) + DIPC 00033710 C 00033720 720 IF(NZF.LT.NUMT)CALL ARSET(XCOM(KPIUSM+NZF),NUMT-NZF,0.0) 00033730 CALL ARMVE(XCOM(KPIUSM),OTR,NUMT) 00033740 GO TO 740 00033750 C 00033760 C ================================================================== 00033770 C OUTPUT PSEUDO-TIME SECTION FOR DATUMING 00033780 C ================================================================== 00033790 C 00033800 730 IMEM5 = MAX0(NUMT,THL) 00033810 IMF = 9 00033820 IF(KPNUSM.LT.IMEM5) GO TO 810 00033830 C 00033840 ITRO = DAWRK 00033850 DAWRK2 = 4*NZ + ITRO 00033860 CALL FORDSD(BDAM1,DAWRK2,XCOM(XD) ) 00033870 C 00033900 CALL USRTHV ( COM(XD), 'THORTN ', IOADR ) 00033910 DAWRK3 = IOADR 00033920 CALL FORDSD(BDAM3,DAWRK3,XCOM(XD+THL) ) 00033930 CALL ARMVE (XCOM(XD+THL),OTR,NUMT ) 00033960 C 00033970 DAWRK = DAWRK + 1 00033980 GO TO 745 00033990 C 00034000 C ==================================================================== 00034010 C PASS TRACES IN SAVE AREA 00034020 C ==================================================================== 00034030 C 00034040 740 CONTINUE 00034050 C 00034060 ITRO = MOD(CSAVE-1,NUMS) + 1 00034070 DAWRK2 = 4*NZ + ITRO 00034080 CALL FORDSD(BDAM1,DAWRK2,COM(KPIUSM) ) 00034090 C 00034120 745 CALL ARMVE (COM(KPIUSM),OH, THL ) 00034130 CALL USSTHV(OH , 'THNS ', NUMT ) 00034140 CALL USSTHV(OH , 'THORTN ', 1 ) 00034150 CALL USSTHV(OH , 'THSEQL ', ITRO ) 00034160 CALL USRTHV(OH , 'THSSP ', SHOTP ) 00034170 C 00034180 KPRTF = 1 00034190 C 00034200 C ----------------KEEP TRACK OF DEPTH POINTS PROCESSED---------------- 00034210 C 00034220 IF ( NS .EQ. 0)WRITE (KPPRNT, 9120 ) 00034230 IF ( NS .EQ. 0 ) GO TO 760 00034240 IF ( PSHOT(NS) .EQ. SHOTP ) GO TO 790 00034250 IF (NS .LT. 12) GO TO 760 00034260 C 00034270 WRITE (KPPRNT, 9130 ) TNS, (PSHOT(I),I=1,NS) 00034280 C 00034290 750 NS = 0 00034300 C 00034310 760 NS = NS + 1 00034320 TNS = TNS + 1 00034330 PSHOT(NS) = SHOTP 00034340 GO TO 790 00034350 C 00034360 C ==================================================================== 00034370 C END PROCESSING - PRINT REMAINING BUFFERS 00034380 C ==================================================================== 00034390 C 00034400 770 KPLOTF = 0 00034410 KPRTF = 0 00034420 KPMOTF = 0 00034430 C 00034440 WRITE (KPPRNT, 9130 ) TNS, (PSHOT(I), I = 1, NS) 00034450 IF(KPBUGF.NE.0) WRITE (KPPRNT, 9020 ) DLOCAL 00034460 C 00034470 CALL FOCSD ( BDAM0 ) 00034480 CALL UGUWRK ( BSAM0, BDAM0, ERR, ERIN ) 00034490 IF(ERR.NE.1) WRITE (KPPRNT, 9140 ) ERR,ERIN 00034500 CALL FOCSD ( BDAM1 ) 00034510 CALL UGUWRK ( BSAM1, BDAM1, ERR, ERIN ) 00034520 IF(ERR.NE.1) WRITE (KPPRNT, 9140 ) ERR,ERIN 00034530 CALL FOCSD ( BDAM2 ) 00034540 CALL UGUWRK ( BSAM2, BDAM2, ERR, ERIN ) 00034550 IF(ERR.NE.1) WRITE (KPPRNT, 9140 ) ERR,ERIN 00034560 CALL FOCSD ( BDAM3 ) 00034570 CALL UGUWRK ( BSAM3, BDAM3, ERR, ERIN ) 00034580 IF(ERR.NE.1) WRITE (KPPRNT, 9140 ) ERR,ERIN 00034590 C 00034600 GO TO 800 00034610 C 00034620 780 KPRTF = 0 00034630 C 00034640 C ----------------SAVE LOCAL VARIABLES--------------- 00034650 C 00034660 790 CALL ARMVE (DLOCAL, COM(KPIRSM), LLOCAL) 00034670 C 00034680 800 RETURN 00034690 C 00034700 810 WRITE (KPPRNT, 9150 ) IMF,KPIUSM,KPNUSM,KPIRSM,KPNRSM, 00034710 * NOWDS 00034720 WRITE (KPPRNT, 9020 ) DLOCAL 00034730 C 00034740 820 KPRTF = -1 00034750 GO TO 800 00034760 C 00034770 830 KPRTF = 0 00034780 GO TO 790 00034790 C 00034800 840 WRITE (KPPRNT, 9160 ) KPNA, KPRNO 00034810 GO TO 820 00034820 C 00034830 850 WRITE (KPPRNT, 9170 ) ERR 00034840 GO TO 820 00034850 C 00034980 900 WRITE (KPPRNT, 9220 ) NEXP 00034990 GO TO 820 00035000 C 00035010 9000 FORMAT(' INITIALIZE FILE 0 - LEN0,NRECS,LCTPSP ',6I8) 00035020 9010 FORMAT (1H ,'RANGES:',12I10) 00035030 9020 FORMAT (1H ,'DLOCAL:',10I12) 00035040 9030 FORMAT (1H ,'SKIPPING SHOT',I6) 00035050 9040 FORMAT(1H0,' FOLLOWING PARAMETERS DETERMINED FOR USE BY ZMPS:',/, 00035060 * /,5X,' FIRST LINE LOCATION = ',I8 ,/, 00035070 * 5X,' LAST LINE LOCATION = ',I8 ,/, 00035080 * 5X,' MAXIMUM DIP = ',F8.1,/, 00035090 * 5X,' LOWEST FREQUENCY = ',F8.1,/, 00035100 * 5X,' HIGHEST FREQUENCY = ',F8.1,/, 00035110 * 5X,' OUTPUT TYPE ID = ',I8 ,/, 00035120 * 5X,' REQUESTED DEPTH STEPS = ',I8 ,/, 00035130 * 5X,' REQUESTED DEPTH INCR = ',I8 ,/, 00035140 * 5X,' DATUMING ELEVATION = ',I8 ,/, 00035150 * 5X,' MAX LEFT RECEIVERS = ',I8 ,/, 00035160 * 5X,' MAX RIGHT RECEIVERS = ',I8 ,/, 00035170 * 5X,' TOTAL SHOTS = ',I8 ,/, 00035180 * 5X,' SHOT SPACING = ',I8 ,/, 00035190 * 5X,' STATION SPACING = ',I8 ,/, 00035200 * 5X,' TOTAL VELOCITY HORIZONS= ',I8 ,/, 00035210 * 5X,' MAXIMUM SEGMENTS = ',I8 ,/, 00035220 * 5X,' MAXIMUM POINTS = ',I8 ,/ ) 00035230 9050 FORMAT (5X,' DEPTH STEP (INCREMENT) = ',F8.2,/, 00035240 * 5X,' NUMBER OF DEPTH STEPS = ',I8 ,/, 00035250 * 5X,' DEPTH STEPS TO MIGRATE = ',I8 ,/) 00035260 9060 FORMAT(' INITIALIZE FILE 1 - LEN,NZ,NX,NRECS ',4I8) 00035270 9070 FORMAT(' INITIALIZE FILE 2 - LEN2,NFCPB,NTPB,NFB,NTB,NRECS',6I8) 00035280 9080 FORMAT(' WRITING IRC,ISHI,ISSP = ',3I10,' AT 470. DAWRK=',I5) 00035290 9090 FORMAT(' WRITING IRC,ISHI,ISSP = ',3I10,' AT 520.DAWRK2=',I5) 00035300 9100 FORMAT(' WRITING IRC,ISHI,ISSP = ',3I10,' AT 560. DAWRK=',I5, 00035310 * ' IOADR = ', I5 ) 00035320 9110 FORMAT(' WRITING IRC,ISHI,ISSP = ',3I10,' AT 570. DAWRK=',I5, 00035330 * ' IOADR = ', I5, ' ISHTS = ', I5 ) 00035340 9120 FORMAT (1H1,//,' COUNT SHOT POINTS PROCESSED') 00035350 9130 FORMAT (1X,I4,' SP',12I10) 00035360 9140 FORMAT (5X,' RETURN FROM UGUWRK WAS ERR,ERIN = ', 2Z10 ) 00035370 9150 FORMAT (5X,'*** NOT ENOUGH MEMORY AVAILABLE',11I8) 00035380 9160 FORMAT (5X,'*** NO PARAMETER RECORDS FOR ',A4,I1) 00035390 9170 FORMAT (5X,' ERROR IN UPAWRK. ERR=', Z10,'. ABORTED.') 00035400 9180 FORMAT (5X,' ERROR IN FGISSD. ERR=', Z10,'. ABORTED.') 00035410 9190 FORMAT (5X,' ERROR IN FGWSSD. ERR=', Z10,'. ABORTED.') 00035420 9200 FORMAT (5X,' ERROR IN FGIDSD. ERR=', Z10,'. ABORTED.') 00035430 9210 FORMAT (5X,' ERROR IN FGRDSD/FGWDSD. ERR=',Z10,'. ABORTED.') 00035440 9220 FORMAT (5X,' SIN/COS TABLE TOO SMALL FOR S2DFT2; NEXP=',I3 ) 00035450 9300 FORMAT('1',2X,'HORIZON',2X,'SEGMENT #',2X,'NG(PTS/SEG.)', 00035460 * 2X,'NW(SEGMENTS/HORIZON)',2X,'NU(NX POSITION',3X,'ND(I)'/) 00035470 9310 FORMAT(2X,' '/) 00035480 9320 FORMAT(5X,I3,4X,I3,10X,I3,12X,I3,18X,I3,11X,I3) 00035490 C 00035500 END 00035510