CTITLESAMPFK0 - 2-D PRE-STACK F-K MIGRATION C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA DESIGNER JAMES SUN CA AUTHOR JAMES SUN/BRUCE VERWEST CA LANGUAGE VS FORTRAN CA SYSTEM IBM (SEE CRAY) CA WRITTEN SEPTEMBER 15,1986 CA C REVISED 12-22-86 JCS RETAIN PRE-MIGRATION MUTE; C SPLIT WORKFILE #1 INTO #1 AND #4 C REVISED 01-05-87 BJV CHANGE TIME FFT LENGHT AND FIX C OFFSET TAPER C REVISED 01-14-87 BJV ADD FINITE SINC INTERPOLATION IN C MAPPING STEP AND CHANGE TIME FFT C BACK TO INPUT LENGTH + 17% C REVISED 01-16-87 BJV ADD LIMIT ON NUMBER OF KH PANELS C PROCESSED BASED ON VELOCITY C AND MODIFIED MMHH PARAMETER C REVISED 01-30-87 JCS CORRECT ERROR FOR POST-STACK MIGRATION C REVISED 02-04-87 BJV CHANGED VELOCITY DEPENDENCE OF KH C LIMIT AND REWROTE WEIGHT CALCULATION C REVISED 02-24-87 BJV CORRECTED MISSING FACTOR OF 2 IN KH C LIMIT AND CHANGED PFACT TO 0.70. C REVISED 02-26-87 BJV ADDED OUTPUT SCALING BASED ON FINITE C FAR OFFSET. C REVISED 03-10-87 JCS ADD 'MAP' OPTION TO PLOT CDP/OFFSET C DISTRIBUTION C REVISED 03-12-87 JCS RENAME WORKFILE #2=>#1 C #3=>#2 C #1=>#3 C THEN FURTHER SPIT #3 AND #4 INTO C #3, #4, #5, #6 C REVISED 03-17-87 JCS EXCLUDE DEAD TRACE FROM FOLD COUNTING; C CORRECT OUTPUT SCALING FOR POST STACK C MIGRATION C REVISED 03-20-87 BJV CHANGED X AND H FFT'S TO NEW LENGTHS C BASED ON POWERS OF 2, 3 AND 5 AND C CHANGED DEFAULT PADDING IN X. C CHANGED DEFAULT KBUFF TO 4000. C REVISED 03-25-87 BJV CHANGED INTERPOLATION TO DEMODULATION C PLUS COEFFICIENTS FROM MCOFGN. ADDED C EXTRAPOLATION OF MUTE TO ZERO OFFSET. C ADDED P -> P TRANSFORM FOR POST-STACK. C REVISED 04-02-87 BJV CHANGED DISK IO IN SAMPFK1 AND SAMPFK7 C TO REDUCE NUMBER OF IO REQUESTS. C REVISED 07-02-87 BJV ADD 1/(ACTUAL FOLD)*C WEIGHT TO IMAGE C BASED ON FRONT END MUTE AND NON-EVAN. C ENERGY. CHANGED SCALING FOR FINITE C OFFSET TO COMPLEMENT FRONT END MUTE C CHANGES. THIS FIXES THE FREQUENCY C SKEW PROBLEMS AND PRESERVES RELATIVE C AMPLITUDE IF INPUT HAS 1/SQRT(T) C (CYLINDRICAL) DIVERGENCE. C REVISED 07-08-87 BJV MAJOR CHANGES IN I/O TO USE UNBUFFERED C ASYNCHRONOUS W.A. PACKAGE. PAD TRACES C OUT TO FULL SECTORS. USE DOUBLE C BUFFERING FOR TRACE INPUT AND DISK C SCATTER AND TRIPLE IN IMAGE STEP. USE C NON-SYMMETRIC SPLITTING OF PANELS IN C THIRD TRANSFORM (SAMPFK1 AND SAMPFK7). C LARGE SAVINGS IN I/O WAIT TIME. C REVISED 07-21-87 BJV ADD PROVISIONS FOR % VELOCITY INCREASE C AND CHANGED DEFAULT X PADDING TO 12000 C C REVISED 09-16-87 WRF READ THE DATA CARD PARAMETERS FROM THE C SEISPARM FILE CREATED IN PREP STEP C REVISED 12-04-87 BJV INCREASED BUFFER BLOCKING ARRAY C DIMENSIONS TO 39 AND 19. C REVISED 12-07-87 BJV CHANGED INTERFACE TO SEISPARM TO USE C 100*PDV WITH ROUNDING C REVISED 02-19-88 BJV ABORT RUN IF XDST IS NEGATIVE, IF C GATHERS NOT IN DPD ORDER OR IF NO C LIVE TRACES ARE FOUND TO PROCESS AND C PRINT APPROPRIATE ERROR MESSAGE. C REVISED 03-21-88 WRF CHANGED THE STORAGE OF VELOCITY INCRE- C MENT IN HEADER BY ROUNDING UP WITH .5 C BEFORE TRUNCATING TO INTEGER C REVISED 04-14-88 WRF CHANGED THE ENTRY POINTS MPFK0,MPFK1, C MPFK2,MPFK3 TO SAMPFK0,SAMPFK1, C SAMPFK2,SAMPFK3 RESPECTIVELY. IN TURN, C SUBROUTINE SAMPFK1,...,SAMPFK7 HAVE C BEEN RENAMED SAMPFKA,...,SAMPFKG AS C REQUIRED BY EDP. C REVISED 05-06-88 WRF ADD REAL ARRAY XATTR=DATTR TO RETRIEVE C DX AND VINC AS FLOATING POINT. C REVISED 05-06-88 FAC FOR PRODUCTION RELEASE - CHANGED ARCY C HEADER UPDATES: THAR61 -> THMPNV C THAR62 -> THMPMV C THAR63 -> THMPDV C THAR64 -> THMPPF C REVISED 07-15-88 WRF ADD TEST OF HEADER MTL=0 TO SEE IF C MUTE HAS BEEN APPLIED, EVEN THOUGH C A TAPER OF 0MS IS ALLOWED BY MUTE. C IF A MUTE WITH ZERO TAPER IS DESIRED C THEN RUN MUTE WITH TAPER LESS THAN C ONE SAMPLE IN LENGTH. C REVISED 09-25-88 ESN CHANGE WA CALLS TO FOSCDK CALLS AND C USE UGUWRK INSTEAD OF RELEASE. C REVISED 11-22-88 JJC CHANGED IT CAN RUN WITHOUT MUTE C APPLIED AND ADDED TO PASS DEAD TRACES C IN ENTRY SAMPFK2. C REVISED 12-20-89 JJC FIXED THE ALLOCATION AND UNALLOCATION C PROBLEMS. C REVISED 01-26-89 JJC CHANGED TO RETURN FOR OUT OF CDP RANGE C BEFORE CHECKING IF THE DPD ORDER. C REVISED 02-10-89 JJC SYNCHRONISED RECENT UPDATES MADE BY C BJV TO DPRBJV VERSION OF MPFK. C BJV'S UPDATES: TIME XFORM TO NONRADIX2 C REARRANGED BUFFERING, REACTIVATED KBUF C REVISED 02-15-89 JJC MADE KP AND KP3 BE DOUBLEWORD BOUNDARY C FOR ESSL SRCFT. C REVISED 03-20-89 JJC ADDED TO CHECK ERROR FOR WORKFILE C ALLOCATION. C REVISED 03-28-89 JJC FIXED THE PROBLEM OF OFFSET MAP. C REVISED 09-18-89 ESN ALLOW CDP SPACING (DF11) TO BE REAL. C REVISED 04-12-90 LWC CHANGED FFT991 CALL TO RFFTMLT. C REVISED 04-30-90 LWC CHANGED RFFTMLT BACK TO FFT991. C REVISED 05-09-91 CLJ BREAK UP WORKFILE INTO EIGHT PARTS C INSTEAD OF FOUR C REVISED 07-11-91 CLJ ADDED JAMES SUN'S CHANGES C 1) CHANGED FOLD COUNT SCHEME C 2) CORRECTED DEAD TRACE HEADER PROB. C REVISED 07-23-91 CLJ REMOVED CHANGE FOR FOLD COUNT SCHEME C C CA CA CA CALL SAMPFK0, SAMPFK1, SAMPFK2 AND SAMPFK3 FROM SDMPFK DRIVER CA CA CA THIS ROUTINE PERFORMS REPEATED PRE-STACK F-K MIGRATION USING CA DIFFERENT CONSTANT VELOCITIES. THE OUTPUT IS IN THE FORM OF CA IMAGED CONSTANT VELOCITY GATHERS. CA C EJECT C ===================================================================== C C PROCESS MPFK -- 2-D PRE-STACK F-K MIGRATION C DATA CARD (1) -- DEFINE CDP RANGE AND PROCESSING PARAMETERS C C NO. OF CARDS: REQUIRED = 1 ALLOWED = 1 C C REQ OR OPT C DF COLS DEFINITION OR DEFAULT C -- ----- ---------- ----------- C 1 1- 4 'MPFK' : REQ : C 2 - 5 PROCESS NUMBER : 0 : C 3 - 6 NOT USED : : C 4 - 7 PROCESSING MODE : D : C 'D' = DEPTH POINT MODE : : C 5 8-10 BLANK : : C 6 11-15 STARTING DEPTH POINT : REQ : C 7 16-20 ENDING DEPTH POINT : DF6 : C 8 21-25 DEPTH POINT SPACING (FT) :NOTE DF8 : C 9 26-30 NUMBER OF CDP TRACES USED FOR PADDING :12000/DF8: C 10 31-35 MAXIMUM OFFSET DISTANCE (FT) : REQ : C 11 36-40 OFFSET DISTANCE SPACING WITHIN CDP GATHER (FT) : REQ : C (SEE NOTE DF11) : : C 12 41-45 NUMBER OF VELOCITIES (LIMIT OF 100) : 1 : C 13 46-50 MINIMUM VELOCITY (FT/SEC) : REQ : C 14 51-55 VELOCITY INCREMENT (FT/SEC) CONSTANT OR % :NOTE DF14: C 15 56-60 HIGH PASS FREQUENCY (HZ) : REQ : C 16 61-65 HIGH CUT FREQUENCY (HZ) : REQ : C 17 66-80 NOT USED : : C ----------- C C DF NOTES C -- ----- C C 4 PROCESSING IS RESTRICTED TO THE DEPTH POINT MODE. THE INPUT C MUST BE UNSTACKED DATA IN DPD GATHER FORM WITH NO NMOC APPLIED. C THE BEST STATICS SOLUTION AVAILABLE SHOULD HAVE ALREADY BEEN C APPLIED TO THE DATA. IT SHOULD HAVE APPROPRIATE TRACE SCALING, C EQUALIZATION, OR AGC APPLIED TO REMOVE ANOMOLOUS NOISES AND HAVE C RELATIVELY UNIFORM AMPLITUDE ACROSS THE ENTIRE DATA VOLUME. C C 8 DEFAULTS TO TRACE HEADER VALUE. FLOATING POINT VALUE IS ALLOWED. C C 9 DEFAULTS TO 12000/DF8. THIS SHOULD BE ADEQUATE FOR MOST CASES. C IF EVENTS ARE SEEN WRAPING AROUND FROM ONE SIDE OF THE SECTION C TO THE OTHER, INCREASE THE PADDING. C C 11 BE CAREFUL WITH THIS ENTRY! IT MUST BE THE ACTUAL SPACING OF C TRACES IN A DEPTH POINT GATHER WHICH IS NOT NECESSARILY THE C GROUP INTERVAL. SEE DISCUSSION BELOW FOR MORE INFORMATION. C C 12 THIS PROCESS IS USED FOR MIGRATION VELOCITY ANALYSIS. THE C -14 VELOCITY VALUE IS PLACED IN THE FILE NUMBER AND OFFSET DISTANCE C LOCATIONS OF THE TRACE HEADER. THE MIGRATION IS REPEATED DF12 C TIMES STARTING WITH THE VELOCITY GIVEN BY DF13. THE VELOCITY IS C INCREMENTED BY DF14 IF DF14 IS .GT. 8.0. IF DF14 IS .LT. 8.0 C OR IF A '%' IS INCLUDED IN DF14, THE VELOCITY IS INCREMENTED BY C DF14 % FROM ONE PANEL TO THE NEXT. NOTE THAT A VALUE FOR DF14 C IS REQUIRED. AN EXPLICIT PERCENT REQUIRES A '%' SIGN IN COL. 55. C A FLOATING POINT FORM FOR THE VELOCITY INCREMENT IS PERMITTED. C THE OUTPUT IS SORTED BY VELOCITY VALUES. FOR SUBSEQUENT C PROCESSING BY VFFK AND VCFK, THE DATA MUST BE RESORTED C USING GATH IN THE DPD MODE AFTER THE MIGRATION. C C 15 HIGH PASS FREQUENCY. C C 16 HIGH CUT FREQUENCY. THE FREQUENCY RANGE DF15-DF16 IS A C ROLLOFF ZONE WHICH IS TAPERED USING A COS**2 TAPER. C C C *** NOTE *** MPFK WILL DELETE AUXILIARY TRACES AND ALL SEISMIC C TRACES NOT IN THE DP RANGE DF6-7 AND NOT IN THE OFFSET C RANGE 0-DF10. C C *** WARNING *** C THE OUTPUT DATA SET FROM MPFK MAY BE LARGER THAN THE INPUT C AND THE NUMBERS ON THE ORIGINAL LINE CARD. IT IS BEST TO C MAKE SURE THAT THE LINE CARD MAXIMUM FOLD IS > OR = C DF12 AND THAT THE LINE CARD (NUMBER OF SHOT POINTS)* C (TRACES PER SHOT) IS > OR = (DF7-DF6+1)*DF12. DO NOT USE C THE EQUIVALENT NUMBER OF SHOT POINTS FOR THIS SINCE C GATHER DOES NOT USE THIS NUMBER CORRECTLY. C C ===================================================================== C EJECT C ===================================================================== C C PROCESS MPFK -- 2-D PRE-STACK F-K MIGRATION C DATA CARD (2) -- DEFINE OFFSET DISTRIBUTION MAP PLOT PARAMETERS C C NO. OF CARDS: REQUIRED = 0 ALLOWED = 1 C C REQ OR OPT C DF COLS DEFINITION OR DEFAULT C -- ----- ---------- ----------- C 1 1- 4 'MPFK' : REQ : C 2 - 5 PROCESS NUMBER : 0 : C 3 - 6 NOT USED : : C 4 - 7 NOT USED : : C 5 8-10 'MAP' : REQ : C 6 11-15 STARTING OFFSET DISTANCE (FT) :NOTE DF6 : C 7 16-20 ENDING OFFSET DISTANCE (FT) :NOTE DF7 : C 8 21-25 OFFSET DISTANCE INCREMENT (FT) :NOTE DF8 : C 9 26-80 NOT USED : : C ----------- C C DF NOTES C -- ----- C C 6 THE DEFAULT IS 0. C 7 THE DEFAULT IS DF10 OF CARD(1). C 8 THE DEFAULT IS DF11 OF CARD(1). HOWEVER, FREQUENTLY IT IS C DESIREABLE TO USE THE GROUP INTERVAL FOR THE MAP. C C ===================================================================== C EJECT C ===================================================================== C C C *** NOTE ON FFT LENGTHS *** C C THE LENGTH OF THE 3 FFTS IN SPACE, OFFSET AND TIME HAVE C A SIGNIFICANT IMPACT ON THE CPU TIME USED BY THIS PROCESS. C C THE LENGTH OF THE FFTS IN SPACE AND OFFSET ARE ABOUT 15% GREATER C THAN THE NUMBER OF DP IN THE RANGE DF6-7 OR THE NUMBER GIVEN BY C DF10/DF11+1. THESE LENGTHS ARE NOT NECESSARILY A POWER OF TWO. C C THE LENGTH OF THE FFT IN TIME IS DEPENDENT ON THE NUMBER OF C SAMPLES IN THE INPUT TRACE(NOSAMP). TO COMPUTE THE FFT LENGTH C IN TIME FIRST COMPUTE NSP AS FOLLOWS C C NSP = 1.17 * NOSAMP C C THE LENGTH OF THE FFT IN TIME IS THE NEXT POWER OF TWO C GREATER THAN NSP. C C THE FOLLOWING TABLES SUMMARIZE THE RELATIONSHIP OF THE C FFT LENGTHS TO THE INPUT TRACE LENGTH. C C C TIME C C LENGTH OF INPUT : LENGTH OF FFT C ----------------:-------------- C : C 28 - 54 : 64 C 55 - 109 : 128 C 110 - 218 : 256 C 219 - 437 : 512 C 438 - 875 : 1024 C 876 - 1750 : 2048 C 1751 - 3500 : 4096 C : C C C EJECT C C C *** NOTE ON OFFSET SPACING PARAMETER DF11 *** C C IT IS IMPORTANT TO CODE THE OFFSET SPACING PARAMETER CORRECTLY. C IT IS EITHER THE GROUP INTERVAL OR SOME MULTIPLE OF THE GROUP C INTERVAL. THIS PARAMETER IS THE C ACTUAL SPACING BETWEEN TRACES IN A CDP GATHER! THE GROUP C INTERVAL IS THE TRACE SPACING IN A SHOT GATHER. FOR SOME RECENT C MARINE LINES WHERE THE DATA HAS BEEN BINNED IN GEOMETRY, THESE C TWO NUMBERS ARE THE SAME AND THE OFFSET-CDP DISTRIBUTION OF THE C TRACES LOOKS LIKE EXAMPLE 1 BELOW. IN THIS CASE USUALLY THE C MAXIMUM CDP FOLD IS EQUAL TO THE NUMBER OF TRACES PER SHOT POINT. C C EXAMPLE 1 C --------- C : * * * * -\ C : :- DF11 C O : * * * * -/ C F : C F : * * * * C S : . . . C E : * * * * C T : C : * * * * -\ C : :- GROUP INTERVAL C : * * * * -/ C ----------------------------------- C CDP C C FOR OLDER MARINE LINES AND SOME LAND LINES THE MAXIMUM CDP FOLD C IS 1/2 THE NUMBER OF TRACES PER SHOT POINT. IN THIS CASE THE C OFFSET-CDP DISTRIBUTION OF THE TRACES LOOKS LIKE EXAMPLE 2 C BELOW. IN THIS CASE DF11 IS 2*GROUP INTERVAL. C C EXAMPLE 2 C --------- C : * * -\ C : : C O : * * :- DF11 C F : : C F : * * -/ C S : . . . C E : * * C T : C : * * -\ C : :- GROUP INTERVAL C : * * -/ C ----------------------------------- C CDP C C FOR SOME OTHER LAND LINES THE MAXIMUM CDP FOLD IS 1/3 THE C NUMBER OF TRACES PER SHOT POINT. IN THIS CASE THE C OFFSET-CDP DISTRIBUTION OF THE TRACES LOOKS LIKE EXAMPLE 3 C BELOW. IN THIS CASE DF11 IS 3*GROUP INTERVAL. C C EXAMPLE 3 C --------- C : * * -\ C : : C O : * * : C F : :- DF11 C F : * * : C S : . . . : C E : * * -/ C T : C : * * -\ C : :- GROUP INTERVAL C : * * -/ C ----------------------------------- C CDP C C IN SOME CASES IT IS ALSO DESIRABLE TO MODIFY THE OFFSET C SPACING OF A LINE USING THE BINNING PROCESS OBIS. THEN C DF11 SHOULD INDICATE THE TRACING SPACING WITHIN A GATHER C FOR THE BINNED DATA. THIS MAY BE DONE TO REDUCE THE NUMBER OF C OFFSETS FOR PROCESSING OR TO CORRECT IRREGULARITIES IN THE C OFFSET SPACING DUE TO X-Y-E COORDINATES IN THE GEOMETRY. C C EJECT C C C *** NOTE ON SPLIT SPREADS *** C C THIS PROGRAM IS NOT ABLE TO HANDLE SPLIT SPREADS. ONE WAY TO C PROCESS SPLIT SPREADS IS TO DPD GATHER THEM AND BIN AND SUM THEM C AS NECESSARY TO PRODUCE A DPD GATHER WITH ONE TRACE PER OFFSET. C THIS SHOULD WORK IF THE DATA FROM THE TWO SIDES OF THE SPREAD C ARE CONSISTANT. IF THERE ARE SIGNIFICANT DIFFERENCES IN THE C TWO SIDES OF THE SPREAD, THEN SELECT THE BETTER SIDE (PERHAPS C THE LONGER ONE IF THE SPLIT IS ASSYMETRIC) AND PROCESS IT. C C *** NOTE ON PREPROCESSING *** C C THE INPUT MUST BE UNSTACKED DATA IN DPD GATHER FORM WITH NO C NMOC APPLIED. THE BEST STATICS SOLUTION AVAILABLE SHOULD HAVE C ALREADY BEEN APPLIED TO THE DATA AND IT SHOULD BE SHIFTED TO A C FLAT DATUM IF NECESSARY. THE DATA SHOULD HAVE TRACE SCALING, C EQUALIZATION, OR AGC APPLIED TO REMOVE ANOMOLOUS NOISES AND HAVE C RELATIVELY UNIFORM AMPLITUDE ACROSS THE ENTIRE DATA VOLUME. C C *** PROCESSING PROCEDURE *** C C STEP 1: PREPROCESSING AND DATA PREPARATION C C STEP 2: C C READ C : C : C MPFK MIGRATE! C : C : C WRIT0 PLOT CONSTANT VELOCITY PANELS ON 11 IN C : PLOTTER FOR VELOCITY PICKING C : C GATH(DPD) GATHER INTO DEPTH POINT VELOCITY GATHERS C : C : C WRIT1 SAVE FOR LATER FINAL INTERPOLATION C : C : C VFFK THIS PROCESS REFORMATS DATA FOR VELOCITY C : SELECTION DISPLAY USING VELD OR C : INTERACTIVE SEISMIC ANALYSIS SYSTEM C : C WRIT2 VELOCITY ANALYSIS OUTPUT C C STEP 3: SELECT VELOCITIES USING PLOT FROM WRIT0 AND VELOCITY C DISPLAYS AND GENERATE VELF CARDS. C C STEP 4: C C VELF INPUT VELOCITY FIELD WITH VELF CARDS C : C : C READ INPUT DATA FROM WRIT1 ABOVE C : C : C VCFK PRODUCE FINAL MIGRATED SECTION C : C : C WRIT3 PLOT FINAL SECTION C C STEPS 3 AND 4 CAN BE REPEATED AS MANY TIMES AS DESIRED C TO REFINE THE VELOCITY FIELD. C C C C C C C EJECT C C SUBROUTINE SAMPFK0(OH,ICC,AUTO3,IABORT,RA) DIMENSION OH(1), OTR(1), RA(1), SA(1),VEL(1) CWRF CHARACTER*80 DATA CHARACTER*8 DDNAME CHARACTER*1 CPCT CHARACTER*2 DNL C C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 12/11/83 COMMON /P/ STARTP(2) COMMON /P/ LCNAME COMMON /P/ LC5 COMMON /P/ LCINT COMMON /P/ LCTYP , M00020 COMMON /P/ LCBGSP COMMON /P/ LCENSP , M00032( 2) COMMON /P/ LCNSP COMMON /P/ LCTPSP COMMON /P/ LCRL COMMON /P/ LCSI COMMON /P/ LCPI COMMON /P/ LCGRPI COMMON /P/ LCMXFD , M00068( 2) COMMON /P/ LCDRYF , M00080( 3) COMMON /P/ ACNAME COMMON /P/ AC0506 COMMON /P/ AC64BC COMMON /P/ ACOPCD COMMON /P/ ACQCF COMMON /P/ ACDIST COMMON /P/ ACPROJ COMMON /P/ ACLNAM ( 5) COMMON /P/ ACCOM ( 8) , M00144 COMMON /P/ ACTYPE COMMON /P/ ACNSP COMMON /P/ ACUSER ( 5) , M00188( 12) COMMON /P/ LHJBNO COMMON /P/ LHLNO COMMON /P/ LHRLNO COMMON /P/ LHTPSP COMMON /P/ LHATSP COMMON /P/ LHSI COMMON /P/ LHORSI COMMON /P/ LHST COMMON /P/ LHORST COMMON /P/ LHDFCD COMMON /P/ LHEXFD COMMON /P/ LHTSCD COMMON /P/ LHVSCD COMMON /P/ LHSWFS COMMON /P/ LHSWFE COMMON /P/ LHSWL COMMON /P/ LHSWCD COMMON /P/ LHTSNO COMMON /P/ LHSWTS COMMON /P/ LHSWTE COMMON /P/ LHSWTT COMMON /P/ LHTCF COMMON /P/ LHBGRF COMMON /P/ LHARCD COMMON /P/ LHMS COMMON /P/ LHSGPL COMMON /P/ LHVPCD COMMON /P/ LHNSP COMMON /P/ LHNDP COMMON /P/ LHNSL COMMON /P/ LHMTPR , M00376( 9) COMMON /P/ KPNA COMMON /P/ KPRNO , M00420 COMMON /P/ KPA COMMON /P/ KPDBGS COMMON /P/ KPDBGA COMMON /P/ KPDBGN COMMON /P/ KPWRKS COMMON /P/ KPWRKD COMMON /P/ KPWKS2 COMMON /P/ KPWKD2 COMMON /P/ KPWKS3 COMMON /P/ KPWKD3 COMMON /P/ KPFCF COMMON /P/ KPIRSM COMMON /P/ KPNRSM COMMON /P/ KPIUSM COMMON /P/ KPNUSM COMMON /P/ KPTIME COMMON /P/ KPRTF COMMON /P/ KPDRTF COMMON /P/ KPMOTF COMMON /P/ KPNBR COMMON /P/ KPIBN COMMON /P/ KPITSV COMMON /P/ KPTAMF COMMON /P/ KPLOTF COMMON /P/ KPMITF COMMON /P/ KPPRNT COMMON /P/ KPPLOT COMMON /P/ KPPLTA COMMON /P/ KPBUGF COMMON /P/ KPWARN COMMON /P/ KPTRIO COMMON /P/ KPWKIO COMMON /P/ KPVOLS , M00556( 144) COMMON /P/ MCCOLR , M01136( 38) COMMON /P/ PTTBLK , M01292 COMMON /P/ PTFATL , M01100( 2) COMMON /P/ PTTHL , M01312( 31) COMMON /P/ PROTAB ( 2) COMMON /P/ ENDP C INTEGER DAWRK INTEGER INH INTEGER OH INTEGER PASS INTEGER YES INTEGER NO INTEGER YES3 INTEGER NO3 INTEGER AUTO3 INTEGER ORTN INTEGER CDPN INTEGER CDPT INTEGER TICD INTEGER XDST INTEGER NS INTEGER SI INTEGER SSP INTEGER FN INTEGER THL INTEGER ULOCAL INTEGER SLOCAL INTEGER S1CVBN INTEGER S1CPCH C CJJ INTEGER KPWKS4(2) CJJ INTEGER KPWKS5(2) CJJ INTEGER KPWKS6(2) INTEGER KPWKS4, KPWKD4 INTEGER KPWKS5, KPWKD5 INTEGER KPWKS6, KPWKD6 CLJ1 INTEGER KPWKS7, KPWKD7 INTEGER KPWKS8, KPWKD8 INTEGER KPWKS9, KPWKD9 INTEGER KPWKSA, KPWKDA CLJ2 C COMMON /HEAD/ ORTN,CDPN,CDPT,TICD,XDST,NS,SI,SSP,FN,THL,LNNO INTEGER PSHOT(24),IVEL(100),OOH(190) COMPLEX CPHASE C COMMON/CMPFKC/IF1,LNT,LW,LW2,IW1,ALPHA,SCALE,CMIN,VMUTE,AFFR,IKHHI COMMON/CMPFKT/NT,DT,NW,DW,NWD2,NWD21,NWP2 COMMON/CMPFKX/NX,DX,NKX,DKX,NKXD2,NKXD21,NKX2,NKXP2 COMMON/CMPFKH/NH,DH,NKH,DKH,NKHD2,NKHD21,NKH2,IHBEG COMMON/CMPFKB/IKXBF(39),IWBF(19),MKXBF(39),MWBF(19), + NBF,MBF,NKXBF,NWBF C INTEGER DATTR ( 96) INTEGER DENTRY (104) INTEGER DAP INTEGER PMODE INTEGER PTS INTEGER DCTYP C REAL XATTR ( 96) C C DENTRY IS AN ARRAY TO HOLD A PARAMETER RECORD. THE DEFINITIONS C OF THE FIRST EIGHT WORDS ARE FIXED. THE REMAINING WORDS ARE C FOR VARIABLE PARAMETERS AND ARE USUALLY ADDRESSED USING "DATTR". C THE MAXIMUM LENGTH OF DENTRY IS 104 BECAUSE OF THE I/O ROUTINES. C EQUIVALENCE (DCTYP , DENTRY (03)) EQUIVALENCE (SPT , DENTRY (04)) EQUIVALENCE (SPE , DENTRY (05)) EQUIVALENCE (NOPAR , DENTRY (06)) EQUIVALENCE (PMODE , DENTRY (07)) EQUIVALENCE (SPLOCN , DENTRY (08)) EQUIVALENCE (DATTR(1) , DENTRY (09)) C EQUIVALENCE (DATTR(1) , XATTR (01)) C DIMENSION IA(110),JA(110),JJH(9) DATA JNO /'0'/ DATA KYES /'K'/ DATA JPOS /'+'/ DATA JNEG /'-'/ DATA JEXA /'*'/ DATA JJH(2) /'2'/ DATA JJH(3) /'3'/ DATA JJH(4) /'4'/ DATA JJH(5) /'5'/ DATA JJH(6) /'6'/ DATA JJH(7) /'7'/ DATA JJH(8) /'8'/ DATA JJH(9) /'9'/ DATA DNL /'DN'/ C DATA YES,NO,YES3,NO3 / 0,1,2,3 / C DATA PTS / 'PTS ' / C 1000 FORMAT(/,' NO TRACE : 0',/, + ' DEAD TRACE : K',/, + ' LIVE TRACE : +, -, OR * FOR SINGLE TRACE',/, + ' OR # FOR MORE THAN ONE TRACE') 1001 FORMAT(1X,I5,2X,11(10A1,1X)) 1002 FORMAT('1',' *** CDP/OFFSET DISTRIBUTION PLOT ***',//, + ' NEAR OFFSET DISTANCE, FT ',I6,/, + ' FAR OFFSET DISTANCE, FT ',I6,/, + ' OFFSET DISTANCE INCREMENT, FT ',F7.2,/, + ' NUMBER OF OFFSET PLOTTED ',I6) 1003 FORMAT(/,5X,' OFFSET DISTANCE, FT =====>') 1004 FORMAT(8X,11(10I1,1X)) 1005 FORMAT(' DPNO') C 5002 FORMAT(/,' COUNT DEPTH POINT PROCESSED',/) 5003 FORMAT(/,1X,'MEMORY NEEDED FOR RESERVED AREA, K-BYTES ',I5) 5004 FORMAT(/,' VELOCITY ',I7,' FT/SEC') 5005 FORMAT(1X,I4,4(2X,6I5)) 5006 FORMAT(///,' NUMBER OF OUTPUT TRACES',I8) C C IPR = KPPRNT IABORT = NO PI2=6.2831853 SAMPR = SI/1000. IXXX = 1 C C AUTO3 = YES C C READ PARAMETER SELECTION FROM SEISPARM FILE CREATED IN PREP STEP C DAP = 1 C 90 CALL FORP (KPNA, KPRNO, DAP, 104, DENTRY, *998) IF (DCTYP .NE. PTS) GO TO 90 C C OBTAIN VARIABLES FROM ATTRIBUTE ARRAY DATTR C C####################################################################### C C READ THE STARTING DP NUMBER FOR THIS PROCESSING RANGE C IXBEG = DATTR(1) C C READ THE ENDING DP NUMBER FOR THIS PROCESSING RANGE C IXEND = DATTR(2) C C----------------------------------------------------------------------- C C OBTAIN THE DEPTH POINT SPACING IN FEET. THE DEFAULT VALUE IS C ZERO WHICH IMPLIES THAT THE DEPTH POINT SPACING IS TO BE TAKEN C FROM THE TRACE HEADERS. NOTE THAT THE VALUE IS A FLOATING POINT C NUMBER. C C----------------------------------------------------------------------- C DX = XATTR (3) C C----------------------------------------------------------------------- C C OBTAIN THE NUMBER OF CDP TRACES TO BE USED FOR PADDING. THE C DEFAULT IS SET TO 12000 DIVIDED BY THE DEPTH POINT SPACING. C C----------------------------------------------------------------------- C NPAD = DATTR (4) C C----------------------------------------------------------------------- C C READ THE MAXIMUM OFFSET DISTANCE IN FEET. THERE IS NO DEFAULT. C C----------------------------------------------------------------------- C IHEND = DATTR (5) C C----------------------------------------------------------------------- C C READ THE OFFSET SPACING IN FEET WITHIN A DEPTH POINT GATHER. C THIS MUST BE THE ACTUAL TRACE SPACING WITHIN THE CDP AND IS C USED IN THE FOURIER TRANSFORMS OVER OFFSET. THERE IS NO DEFAULT C VALUE. C C----------------------------------------------------------------------- C DH2 = XATTR (6) C C----------------------------------------------------------------------- C C READ THE NUMBER OF VELOCITIES TO USE IN THE PROCESS. THE MAXIMUM C NUMBER IS 100. THE DEFAULT VALUE IS ONE. C C----------------------------------------------------------------------- C NV = DATTR (7) C C----------------------------------------------------------------------- C C OBTAIN THE MINIMUM VELOCITY (FT/SEC) TO USE IN THE VELOCITY C ANALYSIS PART OF THE PROCESS. THERE IS NO DEFAULT VALUE. C A ZERO VALUE IS NOT PERMITTED. C C----------------------------------------------------------------------- C IVMIN = DATTR (8) C C----------------------------------------------------------------------- C C OBTAIN THE VELOCITY INCREMENT TO USE IN THE ANALYSIS PART OF C THE PROCESS. A PERCENT CAN BE ENTERED AND THE PANELS WILL C INCREMENT BY THAT PERCENT OF THE PERVIOUS PANEL'S VELOCITY. C A PERCENT SIGN MUST BE ENTERED IN COLUMN 55 FOR THE C PERCENT OPTION. HOWEVER, IF A VALUE LESS THAN 8 (FT/SEC) IS INPUT C THEN THAT VALUE WILL BE USED AS A PERCENT INCREMENT. C RECALL THAT THE VELOCITY INCREMENT WAS INPUT AS A FLOATING POINT C NUMBER. C C----------------------------------------------------------------------- C C WE NEED TO SIGNAL TO THE PROCESS STEP THAT A '%' SIGN IS USED C SO WE SET A FLAG IFLIN. SET TO ONE IF NOT A PERCENT, AND SET C TO ZERO IF A '%' IS USED C VINC = XATTR (9) C C WE ALSO NEED TO RETRIEVE THE FLAG IFLIN WHICH INDICATES WHETHER C THERE WAS A '%' SIGN OR NOT C IFLIN = DATTR (10) C C IF IFLIN = 1 (NO) THEN A '%' SIGN WAS USED C IF (IFLIN .EQ. NO) THEN C C SET CHARACTER FLAG C CPCT = '%' C C IF AN ACTUAL VELOCITY VALUE IS ENTERED THEN SET CHARACTER FLAG C CPCT TO A BLANK C ELSE C CPCT = ' ' C END IF C C PDV = VINC C C----------------------------------------------------------------------- C C READ THE STARTING FREQUENCY FOR HIGH SIDE OF C THE TEMPORAL FREQUENCY DOMAIN FILTER (HIGH-PASS) C TO BEGIN COSINE SQUARED TAPER. THERE IS NO DEFAULT VALUE. C C----------------------------------------------------------------------- C IFPSS = DATTR (11) C C----------------------------------------------------------------------- C C READ THE HIGH-CUT FREQUENCY FOR THE TEMPORAL FREQUENCY DOMAIN C FILTER. THE DEFAULT VALUE WILL BE NYQUIST. C C----------------------------------------------------------------------- C IFCUT = DATTR (12) C C####################################################################### C C NOW NEED TO READ THE SECOND DATA CARD FOR THE PROCESS C IF IT IS THERE. IT IS NOT REQUIRED. C C AS THE PROCESS STEP MUST KNOW WHETHER A 'MAP' CARD IS PRESENT C AND NOT JUST THE PARAMETER VALUES, WE SET UP A FLAG ICMAP C TO INDICATE ITS PRESENCE TO THE PROCESS STEP. WE SET IT TO C UNITY FIRST TO INDICATE THERE IS NO 'MAP' CARD. WE THEN SET C IT TO ZERO IF A 'MAP' CARD IS PRESENT C C####################################################################### C C----------------------------------------------------------------------- C C WE NOW NEED TO GET THE 'MAP' CARD FLAG ICMAP. IF THE VALUE IS C ZERO (YES) THEN A 'MAP' CARD WAS PRESENT C C----------------------------------------------------------------------- C ICMAP = DATTR(13) C C----------------------------------------------------------------------- C C READ THE STARTING OFFSET DISTANCE (FT) FOR PLOTS. THE DEFAULT C VALUE IS ZERO. C C----------------------------------------------------------------------- C IMHBEG = DATTR(14) C C----------------------------------------------------------------------- C C READ THE ENDING OFFSET DISTANCE (FT) FOR PLOTS. THE DEFAULT C VALUE IS THE MAXIMUM OFFSET FROM DF 10 OF DATA CARD (1). C C----------------------------------------------------------------------- C IMHEND = DATTR(15) C C----------------------------------------------------------------------- C C READ THE OFFSET DISTANCE INCREMENT (FT) FOR PLOTS. THE DEFAULT C VALUE IS THE OFFSET DISTANCE SPACING FROM DF 11 OF DATA CARD (1). C C----------------------------------------------------------------------- C XMDH = XATTR(16) RMDH = XMDH/1000.0 C C----------------------------------------------------------------------- C C READ THE BUFFER SIZE C C----------------------------------------------------------------------- C KBUFF = DATTR(17) C C C----------------------------------------------------------------------- C C####################################################################### C CAD KBUFF=5000 MINTAP=100 ITHRSH=3 C NMH=(IMHEND-IMHBEG)/RMDH+1.5 NMH=MIN0(NMH,110) IMHEND=(NMH-1)*RMDH+IMHBEG+0.5 C 7 CONTINUE IF(IFPSS.EQ.0 .AND. IFCUT.EQ.0) THEN IF(DH2.NE.0.) IFBSC=IVMIN/DH2 IFPSS=2.5*IFBSC IFPSS=MIN0(IFPSS,50) ENDIF C IF(IFPSS.EQ.0 .AND. IFCUT.NE.0) THEN IFPSS=IFCUT*.83 ENDIF C IF(IFPSS.NE.0 .AND. IFCUT.EQ.0) THEN IFCUT=IFPSS*1.2 ENDIF C V0 = IVMIN IVEL(1) = V0 C C IPDV IS THE INTEGER FORM OF THE VELOCITY INCREMENT PASSED IN THE C HEADER C IF (IFLIN .EQ. NO) THEN IPDV = 100.0*PDV+0.5 DDD = 1.0+PDV/100. DO 10 IV=2,NV V0 = V0*DDD 10 IVEL(IV)=V0+0.5 ELSE IPDV = PDV + 0.5 DDD = PDV DO 11 IV=2,NV V0 = V0+DDD 11 IVEL(IV)=V0+0.5 ENDIF CMIN=IVEL(1) IVMX=IVEL(NV) C NX=IXEND-IXBEG+1 IF(DX.EQ.0.) CALL USRTHV(OH,'THSPDP ',DX) IF(NPAD .EQ.0) NPAD = 12000./DX C IF(NX.EQ.1) THEN NKX=1 NKXP2=NKX ELSE C N2KX=IFIX(ALOG(FLOAT(NX+NPAD))/ALOG(2.))+1 C NKX=2**N2KX NXP = NX+NPAD CALL SACFLN(NXP,NKX) IF (NKX .EQ. 0) IABORT=YES NKXP2=NKX+2 ENDIF NKX2=NKX*2 NKXD2=NKX/2 NKXD21=NKXD2+1 C C IF(IHEND.EQ.IHBEG) THEN NH=1 DH2=0. ELSE NH=(IHEND-IHBEG)/DH2+1.5 DH=DH2*.5 ENDIF C IF(NH .EQ. 1) THEN NKH=1 NKH2=2 IKHHI=1 MMHH=100 C ELSE C N2KH=IFIX(ALOG(FLOAT(NH)*1.15)/ALOG(2.))+1 C NKH=2**N2KH NHP = 1.15*NH CALL SACFLN(NHP,NKH) IF (NKH .EQ. 0) IABORT=YES NKH2=NKH*2 NKHD2=NKH/2 NKHD21=NKHD2+1 C C IF(MMHH.EQ.0) THEN C MMHH=100 PFACT = 0.70 MMHH=100./NKH+100.*2.0*PFACT*IFCUT*DH/IVMIN MMHH = MIN0(100,MMHH) C ENDIF C IKHHI=NKH*MMHH/100 C IKHHI=IKHHI+MOD(IKHHI,2) ENDIF C C NT=NS DT=FLOAT(SI)*1.E-6 FNYQ=.5/DT FCUT=IFCUT FCUT = AMIN1(FCUT,FNYQ) FPSS=IFPSS FPSS = AMIN1(FPSS,FCUT) FPSS = AMIN1(FPSS,FNYQ) WPSS=FPSS*PI2 WCUT=FCUT*PI2 CAD N2W=IFIX(ALOG(FLOAT(NT)*1.17)/ALOG(2.))+1 CAD NW=2**N2W N2W=1.17*NT CALL SAFFLN(N2W,NW) NWP2=NW+2 NWD2=NW/2 NWD21=NWD2+1 DW=PI2/DT/FLOAT(NW) IW1=WPSS/DW+1 IW1=MIN0(IW1,NWD2) LW=WCUT/DW+1 LW=MIN0(LW,NWD2) LW2=LW*2 LNT = (LW2/512)*512 IF (LNT .LT. LW2) THEN LNT = LNT+512 ENDIF C AFFR = FLOAT(NS)/FLOAT(NW) ALPHA=1.0 C SCALE=0.5/FLOAT(NW*NKX*NKH) IF (NH .GT. 1) THEN CAD SCALE=0.5/FLOAT(NW*NKX)*DH SCALE=1.0/FLOAT(NKX)*DH ELSE CAD SCALE=0.5/FLOAT(NW*NKX) SCALE=1.0/FLOAT(NKX) ENDIF C C WRITE(IPR,6001) NX,IXBEG,IXEND,DX,NPAD,NH,IHBEG,IHEND,DH2,NV, * IVMIN,PDV,CPCT,IVMX,IFPSS,IFCUT,AFFR,MINTAP,ITHRSH,MMHH,IKHHI 6001 FORMAT(' NX =',I10,/, * ' IXBEG =',I10,/, * ' IXEND =',I10,/, * ' DX =',F10.3,/, * ' NPAD =',I10,/, * ' NH =',I10,/, * ' IHBEG =',I10,/, * ' IHEND =',I10,/, * ' DH2 =',F10.3,/, * ' NV =',I10,/, * ' IVMIN =',I10,/, * ' PDV =',F10.3,A1/, * ' IVMAX =',I10,/, * ' IFPSS =',I10,/, * ' IFCUT =',I10,/, * ' AFFR =',F10.3,/, * ' MINTAP =',I10,/, * ' ITHRSH =',I10,/, * ' MMHH =',I10,/, * ' IKHHI =',I10) WRITE(IPR,6003) NKX,NKH,NW,LW,LNT,KBUFF 6003 FORMAT(' NKX =',I10,/, + ' NKH =',I10,/, + ' NW =',I10,/, + ' LW =',I10,/, + ' LNT =',I10,/, + ' KBUFF =',I10) WRITE(IPR,6002) (IVEL(I),I=1,NV) 6002 FORMAT(2X,10I7) C C =================================== C ___________________________________ C RA(KA)--> : W : LW : C :---------:-----------------------: C KB --> : AKX : NKX : C :---------:-----------------------: C KC --> : AKH : NKH : C :---------:-----------------------: C KZ --> : AKZSQ : LW : C :---------:-----------------------: C KDP--> : IFAXW : 13 : C :---------:-----------------------: C KD --> : TRIXST : 3*NW+4 : C :---------:-----------------------: C KE --> : IFAXX : 13 : C :---------:-----------------------: C KF --> : TRIXSX : 2*NKX : C :---------:-----------------------: C KG --> : IFAXH : 13 : C :---------:-----------------------: C KH --> : TRIXSH : 2*NKH : C :---------:-----------------------: C KO --> : WORK : NW+6 /2 : C :---------:-----------------------: C KR --> : WORK : NW+6 /2 : C :---------:-----------------------: C KP --> : P : 2*LW*(MAX(NKX,NKH)+2) : C :---------:-----------------------: C KQ --> : Q : 2*LW*(MAX(NKX,NKH)+2) : C :---------:-----------------------: C C C SET BUFFER SIZE TO BE KBUFF K-BYTE C NBFSZ=KBUFF*256 NKXBF=NBFSZ/LNT/4 LKXBF=2*NKX+4 NWBF=3*NBFSZ/LKXBF/4 C NKXBF=MIN0(NKX+2,NKXBF) NBF=(NKX+1)/NKXBF+1 NKXBF=(NKX+1)/NBF+1 C C NWBF=MIN0(LW,NWBF) MBF=(LW-1)/NWBF+1 NWBF=(LW-1)/MBF+1 C FORCE NWBF TO BE MULTIPLE OF 3 MMMM = MOD(NWBF,3) IF (MMMM .NE. 0) THEN NWBF = NWBF + 3-MMMM ENDIF C IBF=1 IKXBF(IBF)=NKXBF MKXBF(IBF)=IKXBF(IBF) 20 IF(IKXBF(IBF).GE.(NKX+2)) THEN IKXBF(IBF)=NKX+2 NBF=IBF ELSE IBF=IBF+1 IKXBF(IBF)=IKXBF(IBF-1)+NKXBF GO TO 20 ENDIF IF(NX.EQ.1) THEN NBF=1 IKXBF(1)=1 MKXBF(1)=1 ENDIF WRITE(IPR,6102) NBF,(IKXBF(I),I=1,NBF) 6102 FORMAT(' NBF =',I3,' IKXBF =',19I5) KXBFSZ=LNT*MKXBF(1) DO 25 IBF=2,NBF 25 MKXBF(IBF)=IKXBF(IBF)-IKXBF(IBF-1) WRITE(IPR,6105) (MKXBF(I),I=1,NBF) C IBF=1 IWBF(IBF)=NWBF MWBF(IBF)=IWBF(IBF) 30 IF(IWBF(IBF).GE.LW) THEN IWBF(IBF)=LW MBF=IBF ELSE IBF=IBF+1 IWBF(IBF)=IWBF(IBF-1)+NWBF GO TO 30 ENDIF WRITE(IPR,6104) MBF,(IWBF(I),I=1,MBF) 6104 FORMAT(' MBF =',I3,' IWBF =',19I5) KWBFSZ=LKXBF*MWBF(1)/3 IF (MBF .EQ. 1) MWBF(1) = IWBF(1) DO 35 IBF=2,MBF 35 MWBF(IBF)=IWBF(IBF)-IWBF(IBF-1) WRITE(IPR,6105) (MWBF(I),I=1,MBF) 6105 FORMAT(' ',19I5) C NBFSZ=MAX0((NKH+2)*LNT,KXBFSZ,KWBFSZ) C LR=6 C ICOE=1 INORM=ICOE+LR*101 ISHIFT=INORM+101*2 KA=ISHIFT+2*LW+8 KB=KA+LW KC=KB+NKX KZ=KC+NKH CAD KD=KZ+LW KDP=KZ+LW KD=KDP+13 KE=KD+3*NW+4 KF=KE+13 KG=KF+NKX2 KH=KG+13 CAD KO=KH+NKH2 KI=KH+NKH2 KO=KI+NKH KR=KO+NWD2+15 C C MAKE KP AND KP3 BE DOUBLEWORD BOUNDARY FOR ESSL SRCFT C KP=KR+NWD2+15 IF ((KP/2)*2 .EQ. KP) KP = KP + 1 KP2=KP+NBFSZ IF ((KP2/2)*2 .EQ. KP2) KP2 = KP2 + 1 KP3=KP2+NBFSZ IF ((KP3/2)*2 .EQ. KP3) KP3 = KP3 + 1 KQ=KP3+NBFSZ IF ((KQ/2)*2 .EQ. KQ) KQ = KQ + 1 C ICC=KQ+NBFSZ C NTBUF = NBFSZ/(NW+2) C KNRA=(ICC+1023)*4/1024 WRITE(IPR,5003) KNRA C C WORKFILE #1 : TRACE HEADER C C ------------- C ::: :: C ::: :: C THL :::........:: C ::: :: C ::: :: C ------------- C NX C CALL UPAWRK(NX,THL*4,'A',KPWRKS,KPWRKD,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CESN CALL WOPEN(KPWRKS,50,1,IERR) CALL FOISSD (KPWRKS, THL*4, 50) NXTHL=NX*THL C C WORKFILE #2 : COMPLEX P(W,KX) C C ------------- C ::: :: C ::: :: C LW :::........:: C ::: :: C ::: :: C ------------- C NKX+2 C IF1=LNT*NKXP2 CJJ CALL UPAWRK(1,IF1*4,'B',KPWKS2,KPWKD2,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS2,KPWKD2,INDEX2) C C WORKFILE #3, #4, #5, #6 : COMPLEX P(W,KX;KH) CLJ #7, #8, #9, #A C C ------------- . C ::: :: . C ------------- :: C ::: :: :: C ------------- :: :: C ::: :: ::KH3:: C ::: :: ::----- C LW :::........::KH2:: C ::: ::----- C ::: KH1:: C ------------- C NKX+2 C IKHHI4=(IKHHI+7)/8 CCLJ* IKHHI4=(IKHHI+3)/4 CJJ CALL UPAWRK(IKHHI4,IF1*4,'C',KPWKS3,KPWKD3,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS3,KPWKD3,INDEX3) CJJ CALL UPAWRK(IKHHI4,IF1*4,'D',KPWKS4,KPWKD4,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS4,KPWKD4,INDEX4) CJJ CALL UPAWRK(IKHHI4,IF1*4,'E',KPWKS5,KPWKD5,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS5,KPWKD5,INDEX5) CJJ CALL UPAWRK(IKHHI4,IF1*4,'F',KPWKS6,KPWKD6,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS6,KPWKD6,INDEX6) CLJ1 CALL UPAWRK(IKHHI4,IF1*4,'G',KPWKS7,KPWKD7,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS7,KPWKD7,INDEX7) C CALL UPAWRK(IKHHI4,IF1*4,'H',KPWKS8,KPWKD8,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS8,KPWKD8,INDEX8) C CALL UPAWRK(IKHHI4,IF1*4,'I',KPWKS9,KPWKD9,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKS9,KPWKD9,INDEX9) C CALL UPAWRK(IKHHI4,IF1*4,'J',KPWKSA,KPWKDA,DDNAME,IER,IERN) IF (IER .NE. 1) GO TO 9020 CALL UWOPEN(KPWKSA,KPWKDA,INDEXA) CLJ2 C C DOUBLE BUFFER INPUT GATHERS AND WRITE TO DISK C ICFB = 1 USE KP2 C ICBF = 2 USE KQ C ICBF = 2 C MUTMES = YES JFLAG = 0 IXFLAG = 0 IV=0 NS24=0 IXOUT=0 JXOUT=0 IXYOUT=0 NXIN=0 INTLIV = 0 IHMN = IHEND SIGX = 0.0 SIGT = 0.0 C CMAP WRITE(IPR,5002) C C MAP MAP MAP MAP C IF(ICMAP.EQ.YES) THEN WRITE(IPR,1002) IMHBEG,IMHEND,XMDH,NMH WRITE(IPR,1000) WRITE(IPR,1003) C WRITE(IPR,1004) DO 91 IH=1,NMH 91 IA(IH)=(IH-1)*XMDH+IMHBEG+0.5 MDIG=5 IF(IMHEND.LE.9999) MDIG=4 DO 93 IDIG=MDIG,1,-1 MF10=10**(IDIG-1) DO 92 IH=1,NMH JA(IH)=IA(IH)/MF10 92 IA(IH)=IA(IH)-JA(IH)*MF10 93 WRITE(IPR,1004) (JA(IH),IH=1,NMH) WRITE(IPR,1005) ENDIF C C MAP MAP MAP MAP C C RETURN C C C C C SAMPFK1 ENTRY STARTS HERE C******************************************************************* C******************************************************************* C ENTRY SAMPFK1(OH,OTR,VEL,PASS,IABORT,RA,SA) C C******************************************************************* C******************************************************************* C C INHST=0 INLIV=0 INTRT=0 INBUF=0 JHIN = 0 C IF(CDPN .LT. IXBEG .OR. CDPN .GT. IXEND) THEN IXPASS = NO C ELSE IXPASS = YES C CALL ARSET(RA(KO),KP2-KO,0) CALL ARSET(RA(KP3),NBFSZ,0) C SWITCH BUFFERS ICBF = ICBF + 1 IF (ICBF .GT.2) THEN ICBF = 1 ENDIF IF (ICBF .EQ. 1) THEN KPQ = KP2 ELSE KPQ = KQ ENDIF CALL ARSET(RA(KPQ),NBFSZ,0) C IF(JFLAG.EQ.0) THEN C CALL SAMPFKD(RA(KA),RA(KB),RA(KC),RA(KDP),RA(KD),RA(KE),RA(KF), + RA(KG),RA(KH),RA(KO)) C DO 100 IKH=1,IKHHI4 ISEQDA=(IKH-1)*IF1+1 DO 100 IBF=1,NBF JF1=MKXBF(IBF)*LNT IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX3) CALL WRITEWA(INDEX3,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX4) CALL WRITEWA(INDEX4,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX5) CALL WRITEWA(INDEX5,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX6) CALL WRITEWA(INDEX6,RA(KP),ISEQDA,JF1,1) CLJ1 IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX7) CALL WRITEWA(INDEX7,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX8) CALL WRITEWA(INDEX8,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEX9) CALL WRITEWA(INDEX9,RA(KP),ISEQDA,JF1,1) IF (IKH+IBF .GT. 2) CALL WUNIT(INDEXA) CALL WRITEWA(INDEXA,RA(KP),ISEQDA,JF1,1) CLJ2 100 ISEQDA=ISEQDA+JF1 C DO 110 IX=1,NX CESN ISEQDA=(IX-1)*THL+1 CESN CALL PUTWA(KPWRKS,RA(KO),ISEQDA,THL,IERR) DAWRK = IX CALL FOWSSD (KPWRKS,DAWRK,RA(KO)) 110 CONTINUE CALL FOCSD (KPWRKS) CALL FOIDSD (KPWRKD, THL*4) C ISEQDA=1 DO 120 IBF=1,NBF JF1=MKXBF(IBF)*LNT IF (IBF .GT. 1) CALL WUNIT(INDEX2) CALL WRITEWA(INDEX2,RA(KP),ISEQDA,JF1,1) 120 ISEQDA=ISEQDA+JF1 C C SET UP INTERPOLATION COEFFICIENTS C CALL SASINC(LR,RA(ICOE),RA(INORM),RA(ISHIFT),IPR) C JFLAG = 1 END IF C IXIN=CDPN-IXBEG+1 ICDPN=CDPN CALL SCOPY(THL,OH,1,OOH,1) CALL USRTHV(OH,'THFLV ',MUTE) IH0X=XDST IHMN = MIN0(IHMN,IH0X) C C MAP MAP MAP MAP C IF(ICMAP.EQ.YES) THEN IXPASS = YES DO 8 IH=1,NMH IA(IH)=JNO 8 JA(IH)=0 END IF C C MAP MAP MAP MAP C END IF C C C C C******************************************************************* C******************************************************************* C ENTRY SAMPFK2(OH,OTR,VEL,PASS,IABORT,RA,SA) C C******************************************************************* C******************************************************************* C C PASS = NO CJJ CJCS IF (TICD .NE. 1) GO TO 245 C IF(IXPASS.EQ.NO .OR. XDST.LT.IHBEG .OR. XDST.GT.IHEND) RETURN CBJV IF (XDST .LT. 0) THEN IABORT = YES WRITE(IPR,9876) CDPN,CDPT,XDST 9876 FORMAT(' ***** BEWARE OF NEGATIVE XDST ******',/ * ' ***** CDPN,CDPT,XDST = ',3I8,/ * ' ***** RUN ABORTED !!! ') RETURN ENDIF C IF (XDST .LT. IH0X) THEN IABORT = YES WRITE(IPR,9877) CDPN,CDPT,XDST,IH0X 9877 FORMAT(' ***** INPUT GATHERS ARE NOT IN DPD ORDER ****',/ * ' ***** CDPN,CDPT,XDST,IH0X = ',4I8,/ * ' ***** RUN ABORTED !!! ') RETURN ENDIF C C KEEP TRACK OF NUMBER OF TRACES (INHST) C AND NUMBER OF LIVE TRACES (INLIV) IN INPUT GATHER. C INHST=INHST+1 INBUF=INBUF+1 IF(TICD.EQ.1) INLIV=INLIV+1 C CALL USRTHV(OH,'THFLV ',IMUTE) CALL USRTHV(OH,'THMTL ',ITAP ) C CWRF IF MUTE TAPER IS ZERO THEN WE ASSUME THAT NO MUTE HAS BEEN C APPLIED TO THE DATA, EVEN THOUGH A MUTE TAPER OF ZERO IS C PERMITTED BY MUTE PROCESS. IF A MUTE WITH ZERO TAPER IS DESIRED C THEN RUN MUTE WITH A TAPER OF LESS THAN ONE SAMPLE C CJJ IF (ITAP .EQ. 0) THEN C C PRINT MESSAGE AND ABORT AS MUTE IS REQUIRED BEFORE MPFK C CJJ WRITE(IPR, 233) C233 FORMAT('0*** A MUTE TAPER OF 0 MS HAS BEEN DETECTED. IT IS', CJJ + ' ASSUMED THAT MUTE PROCESS HAS NOT BEEN RUN. MUTE', CJJ + ' MUST BE RUN BEFORE MPFK.'/' *** IF MUTE WITH TAPER', CJJ + ' OF 0 MS IS DESIRED, USE TAPER OF 1 MS IN MUTE ***') C C SET ABORT FLAG AND RETURN C CJJ IABORT = YES CJJ RETURN C CJJ END IF C CWRF MUTE=MIN0(MUTE,IMUTE) C IF (TICD .EQ. 1 .AND. NH .GT. 1) THEN C C ACCUMULATE IMFORMATION ON AVERAGE FRONT END MUTE C IF (IMUTE .LT. NS) THEN SIGX = SIGX + XDST TB = (IMUTE-1)*DT SIGT = SIGT + TB ENDIF C C CHECK TO SEE IF MUTE TAPER IS AT LEAST MINMUT MS LONG C IF (IMUTE .GT. 1) THEN IF (ITAP .LT. MINTAP) THEN IF (MUTMES .EQ. YES) THEN WRITE(IPR,235) ITAP,MINTAP 235 FORMAT(/,' INPUT DATA HAD FRONT END TAPER OF ' + ,I5,' MS.',/ + ' CHANGING FRONT END TAPER TO ' + ,I5,' MS.',/) MUTMES = NO ENDIF C C REMOVE PREVIOUS TAPER C IFLV = IMUTE+1 ITPS = ITAP/SAMPR IF (ITPS .GT. 1) THEN TPINC = 1.0/ITPS ITPEND = IMUTE+ITPS-2 ITPEND = MIN0(ITPEND,NS) TINC = TPINC DO 240 I = IFLV,ITPEND OTR(I) = OTR(I)/TINC 240 TINC = TINC + TPINC ENDIF C C APPLY NEW TAPER C ITPS = MINTAP/SAMPR IF (ITPS .GT. 1) THEN TPINC = 1.0/ITPS ITPEND = IMUTE+ITPS-2 ITPEND = MIN0(ITPEND,NS) TINC = TPINC DO 250 I = IFLV,ITPEND OTR(I) = OTR(I)*TINC 250 TINC = TINC + TPINC ENDIF ENDIF ENDIF ENDIF C IF(NH.EQ.1) THEN IHIN=1 ELSE IHIN=(XDST-IH0X)/DH2+1.5 ENDIF CJCS1 CCLJ IF (IHIN .NE. JHIN) THEN CCLJ IF (TICD .EQ. 1) INLIV = INLIV + 1 CCLJ JHIN = IHIN CCLJ ENDIF CJCS2 C CALL ARSET(RA(KI+INBUF-1),1,IHIN) IF (TICD .EQ. 1) THEN IND = (INBUF-1)*NWP2+KP3 CALL SCOPY(NT,OTR,1,RA(IND),1) ENDIF CAD CALL SCOPY(NT,OTR,1,RA(KO),1) CAD CALL ARSET(RA(KO+NT),NW-NT+2,0) CAD CALL RCFFT2(0,1,NW,RA(KO),RA(KD),RA(KP)) CJJ 245 CONTINUE C C C RA(KP3)------------------ C :(XX) (XX) : C :(XX) (XX) : C NWP2 :(XX) (XX) . . : C : : : : C : : : : C : : : : C ------------------ C INBUF C C CHECK TO SEE IF BUFFER FULL. IF IT IS, TRANSFORM, LOAD TO KPQ, C AND RESET C IF (INBUF .EQ. NTBUF) THEN CALL FFT991(RA(KP3),RA(KP),RA(KD),RA(KDP),1,NWP2,NW,INBUF,-1) C CALL RFFTMLT(RA(KP3),RA(KP),RA(KD),RA(KDP),1,NWP2,NW,INBUF,-1) CALL SSCAL(NWD21*INBUF,-1.0,RA(KP3+1),2) DO 255 I=1,INBUF CALL ARSET(IHIN,1,RA(KI+I-1)) IND = (I-1)*NWP2+KP3 IDQ=(IHIN-1)*LNT+KPQ CALL SCOPY(LW2,RA(IND),1,RA(IDQ),1) 255 CONTINUE CALL ARSET(RA(KP3),NBFSZ,0) INTRT = INTRT+INBUF INBUF = 0 ENDIF C C RA(KPQ)------------------ C :(XX) (XX) : C :(XX) (XX) : C LW :(XX) (XX) . . : C : : : : C : : : : C : : : : C ------------------ C NH C CAD IF(NH.EQ.1) THEN CAD IHIN=1 CAD ELSE C IHIN=(XDST-IHBEG)/IDH+1 CAD IHIN=(XDST-IH0X)/IDH+1 CAD ENDIF CAD IDQ=(IHIN-1)*LNT+KPQ CAD CALL SCOPY(LW2,RA(KP),1,RA(IDQ),1) C C MAP MAP MAP MAP MAP C IF(ICMAP.EQ.YES) THEN AIJ=FLOAT(XDST-IMHBEG)/XMDH+1.5 IJ=AIJ IF(IJ.GT.NMH) GO TO 9 RIJ=AIJ-FLOAT(IJ) JA(IJ)=JA(IJ)+1 C IF(JA(IJ).GT.1) THEN IA(IJ)=JJH(JA(IJ)) GO TO 9 ENDIF C IF(TICD.EQ.2) THEN IA(IJ)=KYES GO TO 9 ENDIF C IF(RIJ.GE.0.499999 .AND. RIJ.LE.0.500001) THEN IA(IJ)=JEXA ELSE IF(RIJ.GT.0.500001) THEN IA(IJ)=JPOS ELSE IF(RIJ.LT.0.499999) THEN IA(IJ)=JNEG ENDIF C 9 CONTINUE ENDIF C C MAP MAP MAP MAP MAP C RETURN C******************************************************************* C******************************************************************* C ENTRY SAMPFK3(OH,OTR,VEL,PASS,IABORT,RA,SA) C C******************************************************************* C******************************************************************* C C INHST > 0 ==> STORE P(W,X,KH) C IXFLAG = 0 ==> TRANSFORM X => KX AND MIGRATE C = 2 ==> MIGRATE C = 3 ==> OUT TRACE C = 4 ==> CLOSE DISKS C MIGRATE ONLY IF KPMITF = 0 C PASS = NO C IF(IXPASS.EQ.NO) GO TO 900 IF(INHST.GT.0) THEN GO TO 500 ELSE IF(KPMITF.EQ.1) THEN GO TO 900 ENDIF IF(IXFLAG.EQ.3) GO TO 800 IF(IXFLAG.EQ.2) GO TO 700 IF(IXFLAG.EQ.0) GO TO 600 C C CLOSE DISK (4) C IF(JFLAG.LT.2) THEN CESN CALL WCLOSE(KPWRKS,IERR) CALL FOCDD (KPWRKD) CALL CLOSEWA(INDEX2) CALL CLOSEWA(INDEX3) CALL CLOSEWA(INDEX4) CALL CLOSEWA(INDEX5) CALL CLOSEWA(INDEX6) CLJ1 CALL CLOSEWA(INDEX7) CALL CLOSEWA(INDEX8) CALL CLOSEWA(INDEX9) CALL CLOSEWA(INDEXA) CLJ2 CESN CALL RELEASE(IERR, DNL, KPWRKS) CALL UGUWRK (KPWRKS, KPWRKD, IER, IERN) CESN CALL RELEASE(IERR, DNL, KPWKS2) CALL UGUWRK (KPWKS2, KPWKD2, IER, IERN) CESN CALL RELEASE(IERR, DNL, KPWKS3) CALL UGUWRK (KPWKS3, KPWKD3, IER, IERN) CESN CALL RELEASE(IERR, DNL, KPWKS4) CALL UGUWRK (KPWKS4, KPWKD4, IER, IERN) CESN CALL RELEASE(IERR, DNL, KPWKS5) CALL UGUWRK (KPWKS5, KPWKD5, IER, IERN) CESN CALL RELEASE(IERR, DNL, KPWKS6) CALL UGUWRK (KPWKS6, KPWKD6, IER, IERN) CLJ1 CALL UGUWRK (KPWKS7, KPWKD7, IER, IERN) CALL UGUWRK (KPWKS8, KPWKD8, IER, IERN) CALL UGUWRK (KPWKS9, KPWKD9, IER, IERN) CALL UGUWRK (KPWKSA, KPWKDA, IER, IERN) CLJ2 JFLAG=2 WRITE(IPR,5006) IXYOUT END IF GO TO 900 C C STORE (0) C 500 CONTINUE C C CHECK TO SEE IF BUFFER NON-EMPTY. IF IT IS, TRANSFORM, LOAD TO KPQ, C AND RESET C 6666 FORMAT(1X, 10(E10.4,1X)) IF (INBUF .GT. 0) THEN IF (IXXX .EQ. 1) THEN ENDIF CALL FFT991(RA(KP3),RA(KP),RA(KD),RA(KDP),1,NWP2,NW,INBUF,-1) C CALL RFFTMLT(RA(KP3),RA(KP),RA(KD),RA(KDP),1,NWP2,NW,INBUF,-1) IF (IXXX .EQ. 1) THEN ENDIF IXXX = IXXX + 1 CALL SSCAL(NWD21*INBUF,-1.0,RA(KP3+1),2) DO 505 I=1,INBUF CALL ARSET(IHIN,1,RA(KI+I-1)) IND = (I-1)*NWP2+KP3 IDQ=(IHIN-1)*LNT+KPQ CALL SCOPY(LW2,RA(IND),1,RA(IDQ),1) 505 CONTINUE INTRT = INTRT+INBUF INBUF = 0 ENDIF C C NXIN = NXIN+1 INTLIV = INTLIV + INLIV CALL USRTHV(OOH,'THDPNS ',IDPNS) CALL USSTHV(OOH,'THSSP ',IDPNS) CALL USSTHV(OOH,'THFLV ',MUTE) CALL USSTHV(OOH,'THNHST ', INLIV) CESN ISEQDA=(IXIN-1)*THL+1 CESN CALL PUTWA(KPWRKS,OOH,ISEQDA,THL,IERR) DAWRK = IXIN CALL FOWDSD (KPWRKD, DAWRK, OOH) C C COS TAPER -- W C IF(IW1.NE.LW) THEN CALL SAMPFKF(RA(KPQ)) ENDIF C C COS TAPER -- H C IF(NH.NE.1) THEN CALL SAMPFKE(IHIN,RA(KPQ)) CALL CFFT99(RA(KPQ),RA(KP),RA(KH),RA(KG),LNT/2,1,NKH,LW,-1) ENDIF C C DEMODULATE (TIME SHIFT) BY TMAX/2 FOR INTERPOLATION C DO 290 IW=1,LW IND = 2*(IW-1) CPHASE = CMPLX(RA(ISHIFT+IND),-RA(ISHIFT+IND+1)) 290 CALL CSCAL(NKH,CPHASE,RA(KPQ+IND),LNT/2) C IDQ=KPQ JSEQDA=(IXIN-1)*LNT+1 DO 300 IKH=1,IKHHI C PHASE ARG=-.5*RA(KC+IKH-1)*IH0X CPHASE=CMPLX(COS(ARG),SIN(ARG)) CALL CSCAL(LW,CPHASE,RA(IDQ),1) C PHASE CLJ* LP = (IKH-1)/4 CLJ* MP = MOD(IKH-1,4) LP = (IKH-1)/8 MP = MOD(IKH-1,8) ISEQDA = LP*IF1+JSEQDA IF(MP .EQ. 0) THEN CALL WUNIT(INDEX3) CALL WRITEWA(INDEX3,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 1) THEN CALL WUNIT(INDEX4) CALL WRITEWA(INDEX4,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 2) THEN CALL WUNIT(INDEX5) CALL WRITEWA(INDEX5,RA(IDQ),ISEQDA,LNT,1) CLJ1 CCLJ* ELSE CCLJ* CALL WUNIT(INDEX6) CCLJ* CALL WRITEWA(INDEX6,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 3) THEN CALL WUNIT(INDEX6) CALL WRITEWA(INDEX6,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 4) THEN CALL WUNIT(INDEX7) CALL WRITEWA(INDEX7,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 5) THEN CALL WUNIT(INDEX8) CALL WRITEWA(INDEX8,RA(IDQ),ISEQDA,LNT,1) ELSE IF(MP .EQ. 6) THEN CALL WUNIT(INDEX9) CALL WRITEWA(INDEX9,RA(IDQ),ISEQDA,LNT,1) ELSE CALL WUNIT(INDEXA) CALL WRITEWA(INDEXA,RA(IDQ),ISEQDA,LNT,1) CLJ2 ENDIF C IDQ=IDQ+LNT 300 CONTINUE C C MAP MAP MAP MAP C IF(ICMAP.EQ.YES) THEN WRITE(IPR,1001) CDPN,(IA(I),I=1,NMH) ENDIF C C MAP MAP MAP MAP C INHST = 0 INLIV = 0 IF(KPMITF.EQ.1) GO TO 900 C C X ==> KX C 600 CONTINUE IF (INTLIV .LE. 0) THEN IABORT = YES WRITE(IPR,9878) 9878 FORMAT(' ***** NO LIVE TRACES ACCEPTED BY MPFK ****',/ * ' ***** RUN ABORTED !!! ') GO TO 900 ENDIF C WRITE(IPR,5002) C IF(NH.GT.1) THEN CJJ IF (SIGT .NE. 0.0) THEN VMUTE = SIGX / SIGT ELSE IABORT = YES WRITE (IPR, 238) 238 FORMAT('0*** A ACCUMULATE MUTE TAPER OF 0 MS HAS BEEN ', + 'DETECTED FOR ALL CDPS.'/' *** IF MUTE WITH TAPER', + 'OF 0 MS IS DESIRED, USE TAPER OF 1 MS IN MUTE.') GO TO 900 ENDIF IF (VMUTE .GE. CMIN) THEN IF (IFLIN .EQ. NO) THEN VMUTE = CMIN/(1.0+PDV/100.0) ELSE VMUTE = CMIN-PDV ENDIF ENDIF WRITE(IPR,5007) SIGX,SIGT,VMUTE 5007 FORMAT(/,5X,'SIGX = ',E15.6,' SIGT = ',E15.6,' VMUTE = ', + E15.6,/) ENDIF C CALL ARSET(RA(KP),NBFSZ,0) CCLJ* CALL SAMPFKA(RA(KE),RA(KF),RA(KP),RA(KQ),INDEX3,INDEX4,INDEX5, CCLJ*+ INDEX6,IPR) CALL SAMPFKA(RA(KE),RA(KF),RA(KP),RA(KQ),INDEX3,INDEX4,INDEX5, + INDEX6,INDEX7,INDEX8,INDEX9,INDEXA,IPR) TT=0. C C MIGRATE (2) C 700 CONTINUE CJJ CALL TTIME(TT,DD) WRITE(IPR,5004) IVEL(IV) IV = IV + 1 VELD2=FLOAT(IVEL(IV))*0.5 IXOUT=0 JXOUT=0 C CCLJ* CALL SAMPFKB(VELD2,RA(KA),RA(KB),RA(KC),RA(KZ),RA(KE),RA(KF), CCLJ*+ RA(KO),RA(KR),RA(KP),RA(KQ),RA(ICOE),RA(INORM),LR,RA(ISHIFT), CCLJ*+ INDEX2,INDEX3,INDEX4,INDEX5,INDEX6,ITHRSH,IPR,IABORT) CALL SAMPFKB(VELD2,RA(KA),RA(KB),RA(KC),RA(KZ),RA(KE),RA(KF), + RA(KO),RA(KR),RA(KP),RA(KQ),RA(ICOE),RA(INORM),LR,RA(ISHIFT), + INDEX2,INDEX3,INDEX4,INDEX5,INDEX6, + INDEX7,INDEX8,INDEX9,INDEXA,ITHRSH,IPR,IABORT) C IF(IABORT.EQ.0) GO TO 9999 CJJ CALL TTIME(TT,DD) WRITE(IPR,5004) IVEL(IV) IXFLAG = 3 C IF(NBF.GT.1) THEN IBOUT=1 JF3=LNT*MKXBF(IBOUT) ISEQDA=1 CALL WUNIT(INDEX2) CALL READWA(INDEX2,RA(KQ),ISEQDA,JF3,1) CALL WUNIT(INDEX2) IXBOUT=0 ENDIF C NXTOT = MKXBF(1) IOTRT = 0 C C SET UP SCALING VECTOR IN RA(KO) C CALL ARSET(RA(KO),NT,1.0) IF(IHEND .NE. 0 .AND. NH .GT. 1) THEN APMAX=FLOAT(IHEND) VELC = FLOAT(IVEL(IV)) ALF = (DT*VELC/APMAX)**2 TB = APMAX*SQRT(1.0/VMUTE**2-1.0/VELC**2) ITB = TB/DT+1.0 ITB = MIN0(ITB,NT) CDIR$ IVDEP DO 750 I=ITB,NT 750 RA(KO+I-1) = VMUTE/VELC*SQRT(1.0+ALF*(I-1)**2) ENDIF C C OUTPUT TRACE (3) C 800 PASS = YES3 IF(NBF.EQ.1) GO TO 801 C IF(IXBOUT.EQ.MKXBF(IBOUT)) THEN ISEQDA=LNT*IKXBF(IBOUT)+1 IBOUT=IBOUT+1 JF3=LNT*MKXBF(IBOUT) CALL READWA(INDEX2,RA(KQ),ISEQDA,JF3,1) CALL WUNIT(INDEX2) IXBOUT=0 C NXTOT = MKXBF(IBOUT) IOTRT = 0 C ENDIF IXBOUT=IXBOUT+1 C 801 IXOUT = IXOUT+1 JXOUT = JXOUT+1 IXYOUT=IXYOUT+1 CESN ISEQDA=(IXOUT-1)*THL+1 CESN CALL GETWA(KPWRKS,OH,ISEQDA,THL,IERR) DAWRK = IXOUT CALL FORDSD (KPWRKD, DAWRK, OH) C C SHIFT MUTE TO 0 OFFSET C IF (IV .EQ. 1) THEN CALL USRTHV(OH,'THFLV ',MUTE) T = (MUTE-1)*DT T0 = AMAX1(T*T-(FLOAT(IHMN)/CMIN)**2,0.0) T0 = SQRT(T0) MUTE = T0/DT+1.0 CALL USSTHV(OH,'THFLV ',MUTE) CESN CALL PUTWA(KPWRKS,OH,ISEQDA,THL,IERR) DAWRK = IXOUT CALL FORDSD (KPWRKD, DAWRK, OH) ENDIF C CALL USRTHV(OH,'THCDPN ',CDPN) CALL USRTHV(OH,'THFLV ',MUTE) IF(CDPN.EQ.0) THEN PASS=NO3 JXOUT = JXOUT-1 IXYOUT=IXYOUT-1 GO TO 898 ENDIF CALL USSTHV(OH,'THFN ',IVEL(IV)) CALL USSTHV(OH,'THXDST ',IVEL(IV)) CALL USSTHV(OH,'THTICD ', 1) COADY C CALL USSTHV(OH,'THAR61 ', NV) C CALL USSTHV(OH,'THAR62 ', IVMIN) C CALL USSTHV(OH,'THAR63 ', IPDV) C CALL USSTHV(OH,'THAR64 ', IFLIN) CALL USSTHV(OH,'THMPNV ', NV) CALL USSTHV(OH,'THMPMV ', IVMIN) CALL USSTHV(OH,'THMPDV ', IPDV) CALL USSTHV(OH,'THMPPF ', IFLIN) C CAD IF(NBF.EQ.1) THEN CAD CALL SAMPFKC(IXOUT,RA(KQ),RA(KO),RA(KD),OTR) CAD ELSE CAD CALL SAMPFKC(IXBOUT,RA(KQ),RA(KO),RA(KD),OTR) CAD ENDIF IF(NBF.EQ.1) THEN CALL SAMPFKC(IXOUT ,NXTOT,NTBUF,IOTRT, * RA(KQ),RA(KP),RA(KP2),RA(KD),RA(KDP),OTR,IPR) ELSE CALL SAMPFKC(IXBOUT,NXTOT,NTBUF,IOTRT, * RA(KQ),RA(KP),RA(KP2),RA(KD),RA(KDP),OTR,IPR) ENDIF CALL USRTHV(OH,'THFLV ',MUTE) CALL ARSET(OTR,MUTE-1,0) C C APPLY SCALE FACTOR C CDIR$ IVDEP DO 850 I=1,NT 850 OTR(I) = OTR(I)*RA(KO+I-1) C C C IF (CDPN .EQ. 100 .AND. IV .EQ. 1) THEN C WRITE (IPR,7654) CDPN,IVEL(IV) C WRITE (IPR,7655) (OTR(I),I=1,NT) C7654 FORMAT(/' OUTPUT TRACE - CDP, VEL =',2I8/) C7655 FORMAT(2X,10E12.5) C ENDIF C 899 CONTINUE NS24=NS24+1 PSHOT(NS24)=CDPN IF(NS24.LT.24.AND.JXOUT.LT.NXIN) GO TO 898 WRITE(IPR,5005) JXOUT,(PSHOT(JS),JS=1,NS24) NS24=0 C 898 CONTINUE IF(JXOUT.LT.NXIN) GO TO 900 IF(IV.EQ.NV) THEN IXFLAG=4 ELSE IXFLAG=2 ENDIF C 900 CONTINUE RETURN C C C ******************** C ******************** C ERROR MESSAGES C ******************** C ******************** C C 998 IABORT = YES WRITE(IPR,9998) 9998 FORMAT('0*** ERROR READING SEISPARM FILE ***') RETURN 9999 IABORT = YES WRITE(IPR,9001) 9001 FORMAT('0 NO DATA CARD FOUND') RETURN 9020 IABORT = YES WRITE(IPR,9030) DDNAME, IER, IERN 9030 FORMAT('0*** ALLOCATE DIRECT-ACCESS WORK FILE ', A8, * ' FAILED. IER CODE: ', I2, ' IERN CODE: ', I2, ' ***') RETURN C END