CTITLESAFF3D0 - FAN FILTER FOR 3D IN F-X DOMAIN 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CABS SAFF3D0 - FAN FILTER FOR 3D IN F-X DOMAIN 00020000 CA 00030000 CA DESIGNER D CORRIGAN 00040000 CA AUTHOR D CORRIGAN 00050000 CA LANGUAGE FORTRAN 77 00060000 CA SYSTEM IBM/CRAY 00070000 CA 00080000 C DATE 03-18-91 REWRITE FF3LIB.FORT CODE TO: 00090000 C 1. REVERT TO SINGLE SHOT LOGIC 00100000 C 2. INCORPORATE ANTIALIASING IN 00110000 C FILTER DESIGN 00120000 C 00130000 C REVISED 03-22-91 SOLIDIFY THIS VERSION OF THE 00140000 C CODE BY: 00150000 C 1. REMOVE CDB, PCT AND OPW FROM 00160000 C INPUT PARAMETERS 00170000 C 2. ELIMINATE WEIGHTING OPTION 00180000 C 00190000 C REVISED 04-17-91 ADD OPTION TO REDUCE PHASE 00200000 C DISTORTION (SAFF3DD) 00210000 C 00220000 C REVISED 07-12-91 ADD OPTION TO APPLY A SYMMETRIC 00230000 C PASS FILTER (SAFF3DB) 00240000 C 00250000 C REVISED 09-04-91 ADD LOGIC TO REAPPLY MUTE 00260000 C 00270000 C REVISED 09-22-92 CHECK IRANGE IN SAFF3D3. 00280000 C 00290000 C 00300000 C CALL SAFF3D0(OH,ICC,AUTO3,IABORT,RA) 00310000 C CALL SAFF3D1(OH,OTR,VEL,PASS,IABORT,RA,SA) 00320000 C CALL SAFF3D2(OH,OTR,VEL,PASS,IABORT,RA,SA) 00330000 C CALL SAFF3D3(OH,OTR,VEL,PASS,IABORT,RA,SA) 00340000 C 00350000 C 00360000 C THIS IS A SPARC DEVELOPMENT PROGRAM 00370000 CA 00380000 CA PURPOSE: FAN-REJECT OR FAN-PASS FILTER (IN F-X DOMAIN) 00390000 CA FOR 3-D DATA 00400000 CA 00410000 C************************************************************** 00420000 C * 00430000 C SUBROUTINES AND FUNCTIONS CALLED FROM THIS ROUTINE * 00440000 C * 00450000 C USPHD FORP SAFF3DA SAFF3DB USRTHV ARSET * 00460000 C ARMVE S2DFT2 SCOPY SAFF3DC SAFF3DD SAFF3DE * 00470000 C SAFF3DF * 00480000 C * 00490000 C************************************************************** 00500000 C 00510000 CA EJECT 00520000 CAEND 00530000 C 00540000 C=======================================================================00550000 C 00560000 C LOCAL ARRAYS (INTERNAL TO SUBROUTINE). 00570000 C 00580000 C DATTR ( 96) = ARRAY FOR ATTRIBUTES OF DATA I*4 00590000 C DENTRY ( 104) = ARRAY FOR STORAGE OF PARAMETER RECORDS I*4 00600000 C XATTR ( 96) = ARRAY FOR ATTRIBUTES OF DATA R*4 00610000 C 00620000 C LOCAL VARIABLES AND CONSTANTS (INTERNAL TO SUBROUTINE). 00630000 C 00640000 C AKB = CUT-OFF SPATIAL WAVENUMBER R*4 00650000 C CDB = PARAMETER VALUE WHICH IS THE AMPLITUDE CUTOFF FOR 00660000 C THE FILTER I*4 00670000 C DAP = COUNTER FOR PARAMETER READ & WRITE SUBROUTINES I*4 00680000 C DCTYP = PARAMETER RECORD TYPE 'PTS ' C*4 00690000 C DELF = THE FREQUENCY INTERVAL FROM FFT LENGTH R*4 00700000 C DEPTH = CHARACTER STRING 'DEPTH PT' C*8 00710000 C DIPFLG = FLAG TO INDICATE THE EVENT DIPS (+1 FOR POSITIVE 00720000 C AND -1 FOR NEGATIVE) I*4 00730000 C EDIP = CHARACTER STRING INPUT TO SPECIFY EVENT DIPS C*3 00740000 C FCT = FRACTION OF FILTER REGION FOR TAPER R*4 00750000 C FILEP = CHARACTER STRING 'FILE NO.' A*8 00760000 C FNL = FINAL FN/SP/DP FROM PROCESSING RANGE CARD I*4 00770000 C FST = FIRST FN/SP/DP FROM PROCESSING RANGE CARD I*4 00780000 C F1 = LOW-CUT FREQUENCY FOR REJECT/PASS FILTER R*4 00790000 C F2 = LOW-PASS FREQUENCY FOR REJECT/PASS FILTER R*4 00800000 C F3 = HIGH-PASS FREQUENCY FOR REJECT/PASS FILTER R*4 00810000 C F4 = HIGH-CUT FREQUENCY FOR REJECT/PASS FILTER R*4 00820000 C HMT = LOCAL VARIABLE WHICH CONTAINS THE MAXIMUM NUMBER OF 00830000 C TRACES PER GATHER I*4 00840000 C 00850000 C ICT = TRACE NUMBER BEING OUTPUT I*4 00860000 C IFLV = FIRST LIVE VALUE FOR MUTE ON OUTPUT TRACE I*4 00870000 C IPR = SPARC LOGICAL PRINT UNIT I*4 00880000 C IRANGE = FLAG SET TO UNITY WHEN INPUT GATHER OUT OF PROCESSING 00890000 C RANGE I*4 00900000 C ISAD = SCRATCH COMMON INDEX FOR ARRAY TO HOLD FILTERED DATAI*4 00910000 C ISA1 = SCRATCH COMMON INDEX FOR ARRAY 1 SCALAR PRODUCT I*4 00920000 C ISA2 = SCRATCH COMMON INDEX FOR ARRAY 2 SCALAR PRODUCT I*4 00930000 C ISDX = SCRATCH COMMON INDEX FOR ARRAY TO HOLD DIFFERENTIAL 00940000 C OFFSETS I*4 00950000 C ISTN = SCRATCH COMMON INDEX FOR ARRAY TO HOLD INPUT TRACE 00960000 C NUMBERS I*4 00970000 C ITRC = INPUT TRACE COUNT FOR A SINGLE GATHER I*4 00980000 C IXD = RESERVED COMMON INDEX FOR FREQ. DOMAIN DATA I*4 00990000 C IXDS = RESERVED COMMON INDEX FOR OFFSET SPACING IN TABLE 01000000 C FOR EACH FREQUENCY I*4 01010000 C IXG = RESERVED COMMON INDEX FOR TABLE OF FILTERS VS FREQ* 01020000 C OFFSET I*4 01030000 C IXH = RESERVED COMMON INDEX FOR TRACES AND HEADERS I*4 01040000 C IXID = RESERVED COMMON INDEX FOR TRACE ID'S I*4 01050000 C IXSC = RESERVED COMMON INDEX FOR SCALAR MULTIPLIER FOR EACH 01060000 C FREQUENCY I*4 01070000 C IXXC = RESERVED COMMON INDEX FOR X-COORD. RELATIVE TO SHOT I*4 01080000 C IXXX = RESERVED COMMON INDEX FOR MAXIMUM OFFSET IN TABLE 01090000 C FOR EACH FREQUENCY I*4 01100000 C IXYC = RESERVED COMMON INDEX FOR Y-COORD. RELATIVE TO SHOT I*4 01110000 C JTRC = COUNT OF TRACES BEING OUTPUT I*4 01120000 C JXD = LOCAL VARIABLE TO LOCATE PROPER FREQUENCY DATA I*4 01130000 C JXH = LOCAL VARIABLE TO LOCATE PROPER INPUT TRACE I*4 01140000 C JXID = LOCAL VARIABLE TO LOCATE PROPER LOCATION OF TRACE IDI*4 01150000 C JXXC = LOCAL VARIABLE TO LOCATE PROPER X-COORD I*4 01160000 C JXYC = LOCAL VARIABLE TO LOCATE PROPER Y-COORD I*4 01170000 C KSAD = LOCAL VARIABLE TO LOCATE PROPER FILTER I*4 01180000 C KTRC = LOOP VARIABLE OVER INPUT GATHER TO APPLY FILTER I*4 01190000 C MODE = LOCAL VARIABLE TO INDICATE SHOT/CDP MODE. (MODE=0 FOR 01200000 C SHOT, MODE=1 FOR DEPTH POINT, AND MODE=0 FOR FILE) I*4 01210000 C MRXC = VARIABLE USED TO RETRIEVE RECEIVER X-COORD FROM TRACE 01220000 C HEADER I*4 01230000 C MRYC = VARIABLE USED TO RETRIEVE RECEIVER Y-COORD FROM TRACE 01240000 C HEADER I*4 01250000 C MSXC = VARIABLE USED TO RETRIEVE SHOT X-COORD FROM TRACE 01260000 C HEADER I*4 01270000 C MSYC = VARIABLE USED TO RETRIEVE SHOT Y-COORD FROM TRACE 01280000 C HEADER I*4 01290000 C MTRC = LOCAL VARIABLE USED TO KEEP THE MAXIMUM NUMBER OF 01300000 C TRACES PER GATHER I*4 01310000 C NF = LOCAL VARIABLE WHICH IS THE NUMBER OF FREQUENCIES I*4 01320000 C NOPAR = NUMBER OF PARAMETERS ON SEISPARM RECORD I*4 01330000 C NTIN = LOCAL VARIABLE WHICH IS THE NUMBER OF TRACES FOR THIS 01340000 C OUPUT. DOES NOT SEEM TO BE USED FOR ANYTHING!! I*4 01350000 C NXTAB = PARAMETER STATEMENT VARIABLE WHICH IS THE MAXIMUM 01360000 C NUMBER OF X COMPONENTS TO BE USED I*4 01370000 C OSW = LOCAL VARIABLE WHICH INDICATES TYPE OF OUTPUT DATA 01380000 C DESIRED (OSW=0 FOR DATA OUT; OSW=1 FOR NOISE). 01390000 C NOTE THAT FOR A 'PAS' FILTER THIS SWITCH GETS FLIPPED 01400000 C INTERNALLY. I*4 01410000 C OTYPE = LOCAL VARIABLE WHICH CONTAINS THE DATA TYPE TO BE OUTPUT.01420000 C THIS CAN BE THE STRING 'SIGNAL' OR ' NOISE' C*6 01430000 C 01440000 C PDR = INPUT VARIABLE FLAG FOR APPLYING PHASE DISTORTION 01450000 C REDUCTION (0: DO NOT APPLY; 1: APPLY) I*4 01460000 C PKB = INPUT VARIABLE WHICH IS THE CUTOFF WAVENUMBER AS 01470000 C PERCENTAGE OF SPATIAL NYQUIST I*4 01480000 C PMODE = PROCESSING MODE I*4 01490000 C POX = INPUT VARIABLE FOR MAXIMUM OFFSET NORMAL TO SOURCE- 01500000 C RECEIVER LINE R*4 01510000 C PTS = CHARACTER STRING 'PTS ' C*4 01520000 C WORDS FOR THE SEISPARM RECORD I*4 01530000 C SHOTP = CHARACTER STRING 'SHOT PT' C*8 01540000 C TREC = CURRENT RECORD NUMBER (FN/SSP/CDP) I*4 01550000 C TYPEF = INPUT VARIABLE WHICH IS KIND OF FILTER (0: REJECT; 01560000 C 1: PASS) I*4 01570000 C TYPPNT = CHARACTER STRING WHICH IS SET TO SHOTP OR DEPTH C*8 01580000 C VLC = LOW-CUT VELOCITY FOR PASS FILTER I*4 01590000 C VLP = LOW-PASS VELOCITY FOR PASS FILTER I*4 01600000 C V1 = LOW-CUT VELOCITY FOR REJECT/PASS FILTER I*4 01610000 C V2 = LOW-PASS VELOCITY FOR REJECT/PASS FILTER I*4 01620000 C V3 = HIGH-PASS VELOCITY FOR REJECT FILTER I*4 01630000 C V4 = HIGH-CUT VELOCITY FOR REJECT FILTER I*4 01640000 C 01650000 C EJECT 01660000 C 01670000 C=======================================================================01680000 C 01690000 C PROCESS FF3D -- FAN FILTER FOR 3D 01700000 C 01710000 C DATA CARD (1) -- DEFINE PROCESS PARAMETERS 01720000 C 01730000 C NO. OF CARDS: REQUIRED = 1 ALLOWED = 1 01740000 C 01750000 C 01760000 C REQ OR OPT 01770000 C DF COLS DEFINITION CARD #1 (REQUIRED) OR DEFAULT 01780000 C -- ----- ---------- -----------01790000 C 1 1- 4 'FF3D' º REQ º01800000 C 2 - 5 PROCESS NUMBER º 0 º01810000 C 3 - 6 NOT USED º º01820000 C 4 - 7 PROCESSING MODE ºLINE CARDº01830000 C 'F' = FILE º º01840000 C 'S' = SHOTPOINT º º01850000 C 'D' = DEPTH POINT º º01860000 C 5 8-10 BLANK º º01870000 C 6 11-15 STARTING SHOT POINT, DEPTH POINT º REQ º01880000 C 7 16-20 ENDING SHOT POINT, DEPTH POINT º REQ º01890000 C 8 21-25 MAXIMUM OFFSET NORMAL TO SOURCE-RECEIVER LINE º REQ º01900000 C 9 26-30 HIGH-CUT WAVE NUMBER AS % OF NYQUIST º 150 º01910000 C 10 31-35 OUTPUT TYPE º 'DATA' º01920000 C ' DATA' : OUTPUT TRACES WITH NOISE REMOVED º º01930000 C ' NOIS' : OUTPUT ESTIMATED NOISE º º01940000 C 11 36-40 PHASE DISTORTION REDUCTION: º 0 º01950000 C 0 : DO NOT APPLY DISTORTION REDUCTION º º01960000 C 1 : APPLY PHASE DISTORTION REDUCTION º º01970000 C 15 41-80 NOT USED º º01980000 C º_________º01990000 C 02000000 C 02010000 C DF NOTES 02020000 C -- ----- 02030000 C 02040000 C 1 ONE OF DATA CARD TYPE (2) OR DATA CARD TYPE (3) MUST BE SUPPLIED.02050000 C 02060000 C 9 THIS FIELD IS USED TOGETHER WITH THE GROUP INTERVAL ON THE 02070000 C LINE CARD TO DETERMINE THE MAXIMUM WAVENUMBER TO FILTER IN 02080000 C ORDER TO AVOID ALIASING PROBLEMS. 02090000 C 02100000 C FOR GROUP INTERVAL GI, THE FILTER ROLLS OFF TO ZERO AT 02110000 C WAVENMUBER = (DF09/100)/(2*GI). 02120000 C 02130000 C THE DEFAULT PERCENTAGE IS 150 AND THE ALLOWED RANGE IS 02140000 C (100,180). 02150000 C 02160000 C 02170000 C EJECT 02180000 C=======================================================================02190000 C 02200000 C DATA CARD (2) -- DEFINE REJECT PARAMETERS 02210000 C 02220000 C NO. OF CARDS: REQUIRED = 0 ALLOWED = 1 02230000 C 02240000 C 02250000 C REQ OR OPT 02260000 C DF COLS DEFINITION OR DEFAULT 02270000 C -- ----- ---------- -----------02280000 C 1 1- 4 'FF3D' º REQ º02290000 C 2 - 5 PROCESS NUMBER º 0 º02300000 C 3 - 6 NOT USED º º02310000 C 4 - 7 NOT USED º º02320000 C 5 8-10 'REJ' º º02330000 C 6 11-15 NOT USED º º02340000 C 7 16-20 NOT USED º º02350000 C 8 21-25 LOW CUT FREQUENCY : ------------------ º REQ º02360000 C 9 26-30 LOW PASS FREQUENCY : - DEFINE REJECT º DF8 º02370000 C 10 31-35 HIGH PASS FREQUENCY : - BAND IN F º NYQUIST º02380000 C 11 36-40 HIGH CUT FREQUENCY : ------------------ º DF10 º02390000 C 12 41-45 LOW CUT VELOCITY : ------------------ º REQ º02400000 C 13 46-50 LOW PASS VELOCITY : - DEFINE REJECT º DF12 º02410000 C 14 51-55 HIGH PASS VELOCITY : - BAND IN V º REQ º02420000 C 15 56-60 HIGH CUT VELOCITY : ------------------ º DF14 º02430000 C 16 61-65 EVENT DIP INDICATOR º 'POS' º02440000 C 'POS' : EVENT TIME INCREASES WITH OFFSET º º02450000 C 'NEG' : EVENT TIME DECREASES WITH OFFSET º º02460000 C 17 66-80 NOT USED º º02470000 C º_________º02480000 C 02490000 C EJECT 02500000 C=======================================================================02510000 C 02520000 C DATA CARD (3) -- DEFINE PASS FILTER PARAMETERS 02530000 C 02540000 C NO. OF CARDS: REQUIRED = 0 ALLOWED = 1 02550000 C 02560000 C REQ OR OPT 02570000 C DF COLS DEFINITION OR DEFAULT 02580000 C -- ----- ---------- -----------02590000 C 1 1- 4 'FF3D' º REQ º02600000 C 2 - 5 PROCESS NUMBER º 0 º02610000 C 3 - 6 NOT USED º º02620000 C 4 - 7 NOT USED º º02630000 C 5 8-10 'PAS' º º02640000 C 6 11-15 NOT USED º º02650000 C 7 16-20 NOT USED º º02660000 C 8 21-25 LOW CUT FREQUENCY : ------------------ º REQ º02670000 C 9 26-30 LOW PASS FREQUENCY : - DEFINE PASS º DF8 º02680000 C 10 31-35 HIGH PASS FREQUENCY : - BAND IN F º NYQUIST º02690000 C 11 36-40 HIGH CUT FREQUENCY : ------------------ º DF10 º02700000 C 12 41-45 LOW CUT VELOCITY : ------------------ º REQ º02710000 C 13 46-50 LOW PASS VELOCITY : - DEFINE SYMMETRIC º DF12 º02720000 C : - PASS BAND IN V º º02730000 C : ------------------ º º02740000 C 14 51-80 NOT USED º º02750000 C º_________º02760000 C 02770000 C 02780000 C EJECT 02790000 C=======================================================================02800000 C 02810000 C FORMAT OF PARAMETER RECORDS 'PTS ' 02820000 C 02830000 C 02840000 C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 02850000 C :_______:________:_______:_______:_______:_______:__:_:____:_______: 02860000 C : FF3D : INVOC. : 'PTS ': NOT : NOT : # OF :L/:P:NOT : NOT : 02870000 C :_______:_NUMBER_:_______:__USED_:__USED_:_PARMS_:N_:M:USED:__USED_: 02880000 C 02890000 C WORD 9 WORD 10 WORD 11 WORD 12 WORD 13 WORD 14 WORD 15 WORD 16 02900000 C :________:_______:________:________:________:_______:_______:_______:02910000 C : START : END :MAX OFF.:HIGH-CUT:OUTPUT__:PHASE__:PROCESS:FILTER :02920000 C :_F/S/D__:_F/S/D_:NOR_LINE:% OF KNY:_DATA___:DIS.FLG:_MODE__:_TYPE__:02930000 C 02940000 C FOR A 'REJ' FILTER 02950000 C 02960000 C WORD 17 WORD 18 WORD 19 WORD 20 WORD 21 WORD 22 WORD 23 WORD 24 02970000 C :________:_______:________:________:________:_______:_______:_______:02980000 C :LOW-CUT :LOW-PAS:HIGH-PAS:HIGH-CUT:LOW-CUT :LOW-PAS:HIGH- :HIGH CU:02990000 C : FREQ___:_FREQ__:FREQ____:FREQ____:_VEL____:_VEL___:PAS VEL:T VEL__:03000000 C 03010000 C WORD 25 WORD 26 ......:WORD 104 03020000 C :________:_______:......:_______: 03030000 C :_DIP____:.......:......: NOT : 03040000 C :_FLAG___:.......:......:_USED__: 03050000 C 03060000 C FOR A 'PAS' FILTER 03070000 C 03080000 C WORD 17 WORD 18 WORD 19 WORD 20 WORD 21 WORD 22 WORD 23 WORD 24 03090000 C :________:_______:________:________:________:_______:_______:_______:03100000 C :LOW-CUT :LOW-PAS:HIGH-PAS:HIGH-CUT:LOW-CUT :LOW-PAS: ..... : .... :03110000 C : FREQ___:_FREQ__:FREQ____:FREQ____:_VEL____:_VEL___: ..... : .... :03120000 C 03130000 C WORD 25 WORD 26 ......:WORD 104 03140000 C :________:_______:......:_______: 03150000 C : ...... :.......:......: NOT : 03160000 C : ...... :.......:......:_USED__: 03170000 C 03180000 C 03190000 C EJECT 03200000 C 03210000 C=======================================================================03220000 C LAYOUT OF RESERVED AREA RA 03230000 C 03240000 C ________________________________ 03250000 C IXG --> : TABLE OF FILTERS : 03260000 C : (2*NF*NXTAB WORDS) : 03270000 C :______________________________: 03280000 C IXDX --> : OFFSET SPACING FOR FREQ. : 03290000 C : (NF WORDS) : 03300000 C :______________________________: 03310000 C IXXX --> : MAX OFFSET FOR EACH FREQ. : 03320000 C : (NF WORDS) : 03330000 C :______________________________: 03340000 C IXSC --> : SCALAR MULT. FOR EACH FREQ: 03350000 C : (NF WORDS) : 03360000 C :______________________________: 03370000 C IXXC --> : X-COORD. RELATIVE TO SHOT : 03380000 C : (MTRC WORDS) : 03390000 C :______________________________: 03400000 C IXYC --> : Y-COORD. RELATIVE TO SHOT : 03410000 C : (MTRC WORDS) : 03420000 C :______________________________: 03430000 C IXID --> : TRACE ID FROM HEADER : 03440000 C : (MTRC WORDS) : 03450000 C :______________________________: 03460000 C IXH --> : INPUT HEADERS AND TRACES : 03470000 C : (MTRC*LEN WORDS) : 03480000 C :______________________________: 03490000 C IXD --> : FREQ. DOMAIN DATA : 03500000 C : (2*NF*MTRC WORDS) : 03510000 C :______________________________: 03520000 C 03530000 C 03540000 C LAYOUT OF SCRATCH AREA SA 03550000 C 03560000 C ________________________________ 03570000 C ISTN --> : ARRAY OF INPUT TRACE NO. : 03580000 C : (ITRC WORDS) : 03590000 C :______________________________: 03600000 C ISDX --> : ARRAY OF DIFFER. OFFSETS : 03610000 C : (ITRC WORDS) : 03620000 C :______________________________: 03630000 C ISAD --> : ARRAY OF FILTERED DATA : 03640000 C : (2*NF*ITRC WORDS) : 03650000 C :______________________________: 03660000 C ISA1 --> : ARRAY 1 FOR SCALAR PRODUCT: 03670000 C : (2*ITRC WORDS) : 03680000 C :______________________________: 03690000 C ISA2 --> : ARRAY 2 FOR SCALAR PRODUCT: 03700000 C : (2*NF*MAX(NTIN)) : 03710000 C : (NTIN < OR = MTRC) : 03720000 C :______________________________: 03730000 C 03740000 C====================================================================== 03750000 C 03760000 C 03770000 SUBROUTINE SAFF3D0(OH,ICC,AUTO3,IABORT,RA) 03780000 C 03790000 IMPLICIT INTEGER (A-Z) 03800000 C 03810000 DIMENSION OH(1), OTR(1), RA(1), SA(1),VEL(1) 03820000 REAL OTR,VEL 03830000 REAL SR,POX,AKB,DELF,FCT,F1,F2,F3,F4,ZERO 03840000 C 03850000 INTEGER DENTRY(104),DATTR(96) 03860000 REAL XATTR(96) 03870000 C 03880000 C SET UP A PARAMETER STATEMENT TO SPECIFY SOME FIXED VALUES. 03890000 C IF THESE ARE CHANGED IT WILL BE NECESSARY TO MODIFY THE JSFF3D 03900000 C PROGRAM TO ACCOMMODATE THESE MODIFICATIONS. OTHERWISE THE MEMORY 03910000 C CALCULATION WILL BE INADEQUATE 03920000 C 03930000 C NXTAB - MAXIMUM NUMBER OF OFFSET VALUES THAT CAN BE USED IN 03940000 C THE FILTER TABLE CONSTRUCTION 03950000 C ZERO - THE VALUE 0.0 03960000 C CDB - THE AMPLITUDE CUTOFF VALUE IN DB 03970000 C FCT - THE FRACTION OF FILTER FOR TAPERING 03980000 C 03990000 PARAMETER (NXTAB=500, ZERO=0.0, CDB=18, FCT=.15) 04000000 C 04010000 C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 2/13/92 04020000 COMMON /P/ STARTP ( 2) , M00000( 10) 04030000 COMMON /P/ LCTPSP , M00048( 3) 04040000 COMMON /P/ LCGRPI 04050000 REAL LCGRPI 04060000 COMMON /P/ LCMXFD , M00068( 13) 04070000 COMMON /P/ ACLNAM ( 5) , M00124( 68) 04080000 COMMON /P/ KPNA 04090000 COMMON /P/ KPRNO , M00420( 26) 04100000 COMMON /P/ KPPRNT , M00528( 2) 04110000 COMMON /P/ KPBUGF , M00540( 226) 04120000 COMMON /P/ ENDP 04130000 C 04140000 CHARACTER*8 FILEP 04150000 CHARACTER*8 SHOTP 04160000 CHARACTER*8 DEPTH 04170000 CHARACTER*8 TYPPNT 04180000 CHARACTER*6 OTYPE 04190000 CHARACTER*4 DCTYP 04200000 CHARACTER*4 PTS 04210000 CHARACTER*4 PMODE 04220000 CHARACTER*3 EDIP 04230000 C 04240000 COMMON /HEAD/ ORTN,CDPN,CDPT,TICD,XDST,NS,SI,SSP,FN,THL 04250000 COMMON /USER/ SLOCAL(50), ULOCAL(100) 04260000 C 04270000 EQUIVALENCE (DCTYP , DENTRY (03)) 04280000 EQUIVALENCE (SPT , DENTRY (04)) 04290000 EQUIVALENCE (SPE , DENTRY (05)) 04300000 EQUIVALENCE (NOPAR , DENTRY (06)) 04310000 EQUIVALENCE (PMODE , DENTRY (07)) 04320000 EQUIVALENCE (SPLOCN , DENTRY (08)) 04330000 EQUIVALENCE (DATTR(1) , DENTRY (09)) 04340000 EQUIVALENCE (DATTR(1) , XATTR (01)) 04350000 C 04360000 C DEFINE VARIABLES THAT MUST BE RETAINED FOR REENTRANCY 04370000 C 04380000 EQUIVALENCE (IPR ,ULOCAL( 1)) 04390000 EQUIVALENCE (LEN ,ULOCAL( 2)) 04400000 EQUIVALENCE (FST ,ULOCAL( 3)) 04410000 EQUIVALENCE (FNL ,ULOCAL( 4)) 04420000 EQUIVALENCE (POX ,ULOCAL( 5)) 04430000 EQUIVALENCE (PKB ,ULOCAL( 6)) 04440000 EQUIVALENCE (OSW ,ULOCAL( 7)) 04450000 EQUIVALENCE (PDR ,ULOCAL( 8)) 04460000 EQUIVALENCE (MODE ,ULOCAL( 9)) 04470000 C 04480000 EQUIVALENCE (TYPEF ,ULOCAL(11)) 04490000 EQUIVALENCE (F1 ,ULOCAL(12)) 04500000 EQUIVALENCE (F2 ,ULOCAL(13)) 04510000 EQUIVALENCE (F3 ,ULOCAL(14)) 04520000 EQUIVALENCE (F4 ,ULOCAL(15)) 04530000 EQUIVALENCE (V1 ,ULOCAL(16)) 04540000 EQUIVALENCE (V2 ,ULOCAL(17)) 04550000 EQUIVALENCE (V3 ,ULOCAL(18)) 04560000 EQUIVALENCE (V4 ,ULOCAL(19)) 04570000 EQUIVALENCE (DIPFLG ,ULOCAL(20)) 04580000 C 04590000 EQUIVALENCE (VLC ,ULOCAL(21)) 04600000 EQUIVALENCE (VLP ,ULOCAL(22)) 04610000 EQUIVALENCE (M ,ULOCAL(23)) 04620000 EQUIVALENCE (N ,ULOCAL(24)) 04630000 EQUIVALENCE (IF1 ,ULOCAL(25)) 04640000 EQUIVALENCE (NF ,ULOCAL(26)) 04650000 C 04660000 EQUIVALENCE (IXG ,ULOCAL(31)) 04670000 EQUIVALENCE (IXDX ,ULOCAL(32)) 04680000 EQUIVALENCE (IXXX ,ULOCAL(33)) 04690000 EQUIVALENCE (IXSC ,ULOCAL(34)) 04700000 EQUIVALENCE (IXXC ,ULOCAL(35)) 04710000 EQUIVALENCE (IXYC ,ULOCAL(36)) 04720000 EQUIVALENCE (IXID ,ULOCAL(37)) 04730000 EQUIVALENCE (IXH ,ULOCAL(38)) 04740000 EQUIVALENCE (IXD ,ULOCAL(39)) 04750000 EQUIVALENCE (ITRC ,ULOCAL(40)) 04760000 EQUIVALENCE (JTRC ,ULOCAL(41)) 04770000 EQUIVALENCE (TREC ,ULOCAL(42)) 04780000 EQUIVALENCE (IRANGE ,ULOCAL(43)) 04790000 C 04800000 EQUIVALENCE (TYPPNT ,ULOCAL(51)) 04810000 C 04820000 DATA YES /0/ 04830000 DATA NO /1/ 04840000 DATA YES3 /2/ 04850000 DATA NO3 /3/ 04860000 C 04870000 DATA PTS /'PTS '/ 04880000 DATA FILEP /'FILE NO.'/ 04890000 DATA SHOTP /'SHOT PT'/ 04900000 DATA DEPTH /'DEPTH PT'/ 04910000 C 04920000 C=======================================================================04930000 C 04940000 C INITIALIZE VARIABLES 04950000 C 04960000 IPR = KPPRNT 04970000 IABORT = NO 04980000 SR = SI / 1000. 04990000 AUTO3 = YES 05000000 LEN = THL + NS 05010000 C 05020000 C=======================================================================05030000 C 05040000 C 05050000 C INITIALIZATION 05060000 C ============== 05070000 C 05080000 C FIRST TIME THROUGH 05090000 C 05100000 C 05110000 C PRINT HEADING 05120000 C 05130000 CALL USPHD ( 2, ACLNAM, KPNA, KPRNO, 0, 0, KPPRNT ) 05140000 C 05150000 C 05160000 C=======================================================================05170000 C 05180000 C OBTAIN PROCESSING PARAMETERS 05190000 C 05200000 C=======================================================================05210000 C 05220000 C DETERMINE PROCESSING MODE 05230000 C 05240000 DAP = 1 05250000 200 CONTINUE 05260000 CALL FORP ( KPNA, KPRNO, DAP, 104, DENTRY, *240 ) 05270000 IF (DCTYP .NE. PTS) GO TO 200 05280000 C 05290000 240 CONTINUE 05300000 C 05310000 C#######################################################################05320000 C 05330000 C RETRIEVE THE PROCESSING PARAMETERS 05340000 C 05350000 C READ THE STARTING SP/DP NUMBER FOR THIS PROCESSING RANGE 05360000 C 05370000 FST = DATTR(1) 05380000 C 05390000 C READ THE ENDING SP/DP NUMBER FOR THIS PROCESSING RANGE 05400000 C 05410000 FNL = DATTR(2) 05420000 C 05430000 C-----------------------------------------------------------------------05440000 C 05450000 C MAXIMUM OFFSET NORMAL TO SOURCE-RECEIVER LINE 05460000 C 05470000 C-----------------------------------------------------------------------05480000 C 05490000 POX = XATTR(3) 05500000 C 05510000 C-----------------------------------------------------------------------05520000 C 05530000 C OBTAIN THE HIGH-CUT WAVE NUMBER AS A PERCENT OF SPATIAL NYQUIST 05540000 C 05550000 C-----------------------------------------------------------------------05560000 C 05570000 PKB = DATTR(4) 05580000 C 05590000 C-----------------------------------------------------------------------05600000 C 05610000 C DETERMINE THE CORRECT OUTPUT DATA TYPE AND SET SWITCH 05620000 C 05630000 C-----------------------------------------------------------------------05640000 C 05650000 OSW = DATTR(5) 05660000 C 05670000 IF (OSW .EQ. 0) OTYPE = 'SIGNAL' 05680000 IF (OSW .EQ. 1) OTYPE = ' NOISE' 05690000 C 05700000 C-----------------------------------------------------------------------05710000 C 05720000 C READ THE PHASE DISTORTION REDUCTION SWITCH 05730000 C 05740000 C-----------------------------------------------------------------------05750000 C 05760000 PDR = DATTR(6) 05770000 C 05780000 C-----------------------------------------------------------------------05790000 C 05800000 C OBTAIN THE PROCESS MODE (0=SSP,1=CDP,2=FILE) 05810000 C 05820000 C-----------------------------------------------------------------------05830000 C 05840000 MODE = DATTR(7) 05850000 C 05860000 C SET TYPPNT DEPENDING UPON MODE 05870000 C 05880000 IF (MODE .EQ. 0) TYPPNT = SHOTP 05890000 IF (MODE .EQ. 1) TYPPNT = DEPTH 05900000 IF (MODE .EQ. 2) TYPPNT = FILEP 05910000 C 05920000 C-----------------------------------------------------------------------05930000 C 05940000 C OBTAIN THE KIND OF FILTER (0=REJECT, 1=PASS) 05950000 C 05960000 C-----------------------------------------------------------------------05970000 C 05980000 TYPEF = DATTR(8) 05990000 C 06000000 C=======================================================================06010000 C 06020000 C NOW GET THE 'REJ' FILTER CARD IF NEEDED 06030000 C 06040000 C=======================================================================06050000 C 06060000 IF (TYPEF .EQ. 0) THEN 06070000 C 06080000 C-----------------------------------------------------------------------06090000 C 06100000 C READ THE LOW-CUT FREQUENCY IN HZ 06110000 C 06120000 C-----------------------------------------------------------------------06130000 C 06140000 F1 = DATTR(09) 06150000 C 06160000 C-----------------------------------------------------------------------06170000 C 06180000 C READ THE LOW-PASS FREQUENCY IN HZ 06190000 C 06200000 C-----------------------------------------------------------------------06210000 C 06220000 F2 = DATTR(10) 06230000 C 06240000 C-----------------------------------------------------------------------06250000 C 06260000 C READ THE HIGH-PASS FREQUENCY IN HZ 06270000 C 06280000 C-----------------------------------------------------------------------06290000 C 06300000 F3 = DATTR(11) 06310000 C 06320000 C-----------------------------------------------------------------------06330000 C 06340000 C READ THE HIGH-CUT FREQUENCY IN HZ 06350000 C 06360000 C-----------------------------------------------------------------------06370000 C 06380000 F4 = DATTR(12) 06390000 C 06400000 C-----------------------------------------------------------------------06410000 C 06420000 C READ THE LOW-CUT VELOCITY FOR REJECT FILTER 06430000 C 06440000 C-----------------------------------------------------------------------06450000 C 06460000 V1 = DATTR(13) 06470000 C 06480000 C-----------------------------------------------------------------------06490000 C 06500000 C READ THE LOW-PASS VELOCITY FOR REJECT FILTER 06510000 C 06520000 C-----------------------------------------------------------------------06530000 C 06540000 V2 = DATTR(14) 06550000 C 06560000 C-----------------------------------------------------------------------06570000 C 06580000 C READ THE HIGH-PASS VELOCITY FOR REJECT FILTER 06590000 C 06600000 C-----------------------------------------------------------------------06610000 C 06620000 V3 = DATTR(15) 06630000 C 06640000 C-----------------------------------------------------------------------06650000 C 06660000 C READ THE HIGH-CUT VELOCITY FOR REJECT FILTER 06670000 C 06680000 C-----------------------------------------------------------------------06690000 C 06700000 V4 = DATTR(16) 06710000 C 06720000 C-----------------------------------------------------------------------06730000 C 06740000 C READ THE EVENT DIP INDICATOR 06750000 C 06760000 C-----------------------------------------------------------------------06770000 C 06780000 DIPFLG = DATTR(17) 06790000 C 06800000 IF (DIPFLG .GT. 0) EDIP = 'POS' 06810000 IF (DIPFLG .LT. 0) EDIP = 'NEG' 06820000 C 06830000 ELSE 06840000 C 06850000 C=======================================================================06860000 C 06870000 C OR READ THE 'PAS' CARD IF NEEDED 06880000 C 06890000 C=======================================================================06900000 C 06910000 C-----------------------------------------------------------------------06920000 C 06930000 C READ THE LOW-CUT FREQUENCY IN HZ 06940000 C 06950000 C-----------------------------------------------------------------------06960000 C 06970000 F1 = DATTR(09) 06980000 C 06990000 C-----------------------------------------------------------------------07000000 C 07010000 C READ THE LOW-PASS FREQUENCY IN HZ 07020000 C 07030000 C-----------------------------------------------------------------------07040000 C 07050000 F2 = DATTR(10) 07060000 C 07070000 C-----------------------------------------------------------------------07080000 C 07090000 C READ THE HIGH-PASS FREQUENCY IN HZ 07100000 C 07110000 C-----------------------------------------------------------------------07120000 C 07130000 F3 = DATTR(11) 07140000 C 07150000 C-----------------------------------------------------------------------07160000 C 07170000 C READ THE HIGH-CUT FREQUENCY IN HZ 07180000 C 07190000 C-----------------------------------------------------------------------07200000 C 07210000 F4 = DATTR(12) 07220000 C 07230000 C-----------------------------------------------------------------------07240000 C 07250000 C READ THE LOW-CUT VELOCITY FOR PASS FILTER 07260000 C 07270000 C-----------------------------------------------------------------------07280000 C 07290000 VLC = DATTR(13) 07300000 C 07310000 C-----------------------------------------------------------------------07320000 C 07330000 C READ THE LOW-PASS VELOCITY FOR PASS FILTER 07340000 C 07350000 C-----------------------------------------------------------------------07360000 C 07370000 VLP = DATTR(14) 07380000 C 07390000 C-----------------------------------------------------------------------07400000 ENDIF 07410000 C 07420000 C=======================================================================07430000 C IN CASE OF MULTIPLE RANGE CARDS RETURN FOR MORE CARDS 07440000 C (ONLY ONE RANGE CARD IS PERMITTED) 07450000 C GO TO XXXX 07460000 C 07470000 C#######################################################################07480000 C 07490000 C***********************************************************************07500000 C 07510000 C PRINT INPUT PARAMETERS READ FROM DISK PARAMETER FILE 07520000 C 07530000 C***********************************************************************07540000 C 07550000 WRITE ( KPPRNT, 9000 ) TYPPNT, FST, TYPPNT, FNL 07560000 9000 FORMAT ('0FAN FILTER FOR 3D FROM ', A8,1X,I5,' TO ', 07570000 +A8,1X,I5,' PARAMETER VALUES SELECTED ARE'/1X,90('=')) 07580000 C 07590000 WRITE ( KPPRNT, 9020 ) FST, FNL, POX, PKB, OTYPE, PDR 07600000 9020 FORMAT( 07610000 + '0 FIRST INPUT RECORD = ',I6,T60, 07620000 + ' LAST INPUT RECORD = ',I6,/, 07630000 + ' MAXIMUM PERPENDICULAR OFFSET = ',F6.0,T60, 07640000 + ' HIGH-CUT WAVENUMBER (%KNYQ) = ',I6,/, 07650000 + ' OUTPUT SIGNAL OR NOISE = ',A6,T60, 07660000 + ' PHASE DISTORTION OPTION FLAG = ',I6 ) 07670000 C 07680000 C PRINT SELECTED PARAMETERS FOR REJECT FILTER IF THAT IS TYPE 07690000 C 07700000 IF (TYPEF .EQ. 0) WRITE ( KPPRNT, 9040 ) INT(F1), INT(F2), 07710000 + INT(F3), INT(F4), V1, V2, V3, V4, EDIP 07720000 9040 FORMAT('0 REJECT FAN-FILTER SPECIFICATION - ',/, 07730000 + ' NOISE LOW CUT FREQUENCY = ',I6,T60, 07740000 + ' NOISE LOW PASS FREQUENCY = ',I6,/, 07750000 + ' NOISE HIGH PASS FREQUENCY = ',I6,T60, 07760000 + ' NOISE HIGH CUT FREQUENCY = ',I6,/, 07770000 + ' NOISE LOW CUT VELOCITY = ',I6,T60, 07780000 + ' NOISE LOW PASS VELOCITY = ',I6,/, 07790000 + ' NOISE HIGH PASS VELOCITY = ',I6,T60, 07800000 + ' NOISE HIGH CUT VELOCITY = ',I6,/, 07810000 + ' EVENT DIP OF VELOCITIES = ',A6 ) 07820000 C 07830000 C PRINT SELECTED PARAMETERS FOR PASS FILTER IF THAT IS TYPE 07840000 C 07850000 IF (TYPEF .EQ. 1) WRITE ( KPPRNT, 9060 ) INT(F1), INT(F2), 07860000 + INT(F3), INT(F4), VLC, VLP 07870000 9060 FORMAT('0 PASS FAN-FILTER SPECIFICATION - ',/, 07880000 + ' SIGNAL LOW-CUT FREQUENCY = ',I6,T60, 07890000 + ' SIGNAL LOW-PASS FREQUENCY = ',I6,/, 07900000 + ' SIGNAL HIGH-PASS FREQUENCY = ',I6,T60, 07910000 + ' SIGNAL HIGH-CUT FREQUENCY = ',I6,/, 07920000 + ' SIGNAL LOW CUT VELOCITY = ',I6,T60, 07930000 + ' SIGNAL LOW PASS VELOCITY = ',I6 ) 07940000 C 07950000 C***********************************************************************07960000 C=======================================================================07970000 C 07980000 C USE LINE CARD TO OBTAIN NUMBER OF TRACES/SPN(CDP) 07990000 C AND GROUP INTERVAL 08000000 C 08010000 C SET MAXIMUM NUMBER OF TRACES IN FILE/SSP/CDP 08020000 C 08030000 IF (MODE .EQ. 1) THEN 08040000 MTRC = LCMXFD 08050000 ELSE 08060000 MTRC = LCTPSP 08070000 ENDIF 08080000 C 08090000 C SET THE PERCENTAGE OF SPATIAL NYQUISTTO A REAL NUMBER 08100000 C 08110000 AKB = (PKB / 100. ) / (2. * LCGRPI ) 08120000 C 08130000 C=======================================================================08140000 C 08150000 C SET UP FOR PROCESSING 08160000 C 08170000 M = 5 08180000 N = 32 08190000 320 CONTINUE 08200000 M = M + 1 08210000 N = 2 * N 08220000 IF (N .LT. NS) GO TO 320 08230000 C 08240000 DELF = 1000.0 / (SR * FLOAT ( N ) ) 08250000 C 08260000 C CONVERT FREQENCY TO NEAREST FFT FREQUENCY INDEX 08270000 C 08280000 IF1 = F1 / DELF + 1 08290000 IF4 = F4 / DELF + 1 08300000 NF = IF4 - IF1 + 1 08310000 F1 = (IF1 - 1 ) * DELF 08320000 C 08330000 C=======================================================================08340000 C 08350000 C ALLOCATE RA AREAS FOR STORAGE: 08360000 C 08370000 C IXG - TABLE OF FILTERS (NXTAB,NF) 08380000 C IXDX - OFFSET SPACING IN TABLE FOR EACH FREQUENCY 08390000 C IXXX - MAXIMUM OFFSET IN TABLE FOR EACH FREQUENCY 08400000 C IXSC - SCALAR MULTIPLIER FOR EACH FREQUENCY 08410000 C IXXC - X-COORDINATES RELATIVE TO SHOT 08420000 C IXYC - Y-COORDINATES RELATIVE TO SHOT 08430000 C IXID - TRACE ID-S 08440000 C IXH - INPUT TRACES AND HEADERS 08450000 C IXD - FREQUENCY DOMAIN DATA 08460000 C 08470000 IXG = 1 08480000 IXDX = IXG + 2 * NF * NXTAB 08490000 IXXX = IXDX + NF 08500000 IXSC = IXXX + NF 08510000 IXXC = IXSC + NF 08520000 IXYC = IXXC + MTRC 08530000 IXID = IXYC + MTRC 08540000 IXH = IXID + MTRC 08550000 IXD = IXH + MTRC * LEN 08560000 ICC = IXD + 2 * NF * MTRC 08570000 C 08580000 C IF DEBUG THEN PRINT RESERVED COMMON INDICIES 08590000 C 08600000 IF (KPBUGF .GT. 0) THEN 08610000 C 08620000 WRITE (IPR,*) 'IXG = ', IXG , ' IXDX = ', IXDX 08630000 WRITE (IPR,*) 'IXXX = ', IXXX , ' IXSC = ', IXSC 08640000 WRITE (IPR,*) 'IXXC = ', IXXC , ' IXYC = ', IXYC 08650000 WRITE (IPR,*) 'IXID = ', IXID , ' IXH = ', IXH 08660000 WRITE (IPR,*) 'IXD = ', IXD 08670000 WRITE (IPR,*) 'ICC = ', ICC 08680000 C 08690000 END IF 08700000 C 08710000 C=======================================================================08720000 C 08730000 C CONSTRUCT TABLE OF FILTERS 08740000 C 08750000 C RA(IXG) : FILTERS (NXTAB,NF) 08760000 C RA(IXDX): OFFSET INCREMENTS FOR EACH FREQUENCY 08770000 C RA(IXXX): MAXIMUM OFFSET FOR EACH FREQUENCY 08780000 C 08790000 C FOR REJECT FILTER CALL SAFF3DA TO CREATE FILTER TABLE 08800000 C 08810000 IF (TYPEF .EQ. 0) THEN 08820000 CALL SAFF3DA ( RA(IXG), NXTAB, NF, RA(IXDX), RA(IXXX), RA(IXSC)08830000 + , DELF, F1, F2, F3, F4, V1, V2, V3, V4, DIPFLG, AKB, CDB, 08840000 + FCT) 08850000 ELSE 08860000 C 08870000 C FOR PASS FILTER CALL SAFF3DB TO CREATE FILTER TABLE 08880000 C ALSO NEED TO FLIP THE OUTPUT DATA SWITCH FOR PASS FILTER 08890000 C 08900000 IF (OSW .EQ. 0) THEN 08910000 OSW = 1 08920000 ELSE 08930000 OSW = 0 08940000 END IF 08950000 C 08960000 CALL SAFF3DB ( RA(IXG), NXTAB, NF, RA(IXDX), RA(IXXX), RA(IXSC)08970000 + , DELF, F1, F2, F3, F4, VLC, VLP, CDB, FCT ) 08980000 ENDIF 08990000 C 09000000 RETURN 09010000 C 09020000 C SAFF3D1 ENTRY STARTS HERE 09030000 C******************************************************************* 09040000 C******************************************************************* 09050000 C 09060000 ENTRY SAFF3D1 ( OH, OTR, VEL, PASS, IABORT, RA, SA ) 09070000 C 09080000 C******************************************************************* 09090000 C******************************************************************* 09100000 C 09110000 IABORT = NO 09120000 PASS = NO 09130000 TREC = SSP 09140000 IF (MODE .EQ. 1) TREC = CDPN 09150000 IF (MODE .EQ. 2) TREC = FN 09160000 C 09170000 C CHECK IF GATHER WITHIN PROCESS RANGE 09180000 C 09190000 IF ((TREC .GE. FST .AND. TREC .LE. FNL ) .OR. (TREC .LE. FST 09200000 + .AND. TREC .GE. FNL ) ) THEN 09210000 C 09220000 C SET GATHER WITHIN RANGE FLAG TO ZERO 09230000 C 09240000 IRANGE = 0 09250000 C 09260000 C INITIALIZE TRACE COUNTERS 09270000 C 09280000 ITRC = 0 09290000 JTRC = 0 09300000 C 09310000 ELSE 09320000 C 09330000 C IF GATHER NOT IN RANGE SET OUT OF RANGE FLAG TO UNITY 09340000 C 09350000 IRANGE = 1 09360000 C 09370000 END IF 09380000 C 09390000 C SAFF3D2 ENTRY STARTS HERE 09400000 C******************************************************************* 09410000 C******************************************************************* 09420000 C 09430000 ENTRY SAFF3D2 ( OH, OTR, VEL, PASS, IABORT, RA, SA ) 09440000 C 09450000 C******************************************************************* 09460000 C******************************************************************* 09470000 C 09480000 C 09490000 PASS = NO 09500000 C 09510000 C CHECK FOR OUT OF RANGE GATHER 09520000 C 09530000 IF (IRANGE .EQ. 1) RETURN 09540000 C 09550000 C COUNT INPUT TRACES PER GATHER 09560000 C 09570000 ITRC = ITRC + 1 09580000 C 09590000 C FETCH SOURCE COORDINATES FROM HEADER 09600000 C 09610000 CALL USRTHV ( OH, 'THSRXC ', MSXC ) 09620000 CALL USRTHV ( OH, 'THSRYC ', MSYC ) 09630000 C 09640000 C FETCH RECEIVER COORDINATES FROM HEADER 09650000 C 09660000 CALL USRTHV ( OH, 'THRXC ', MRXC ) 09670000 CALL USRTHV ( OH, 'THRYC ', MRYC ) 09680000 C 09690000 C=======================================================================09700000 C 09710000 C FOR EACH INPUT TRACE: 09720000 C 09730000 C 1. STORE TICD AND RELATIVE COORDINATES IN RA 09740000 C 2. STORE FFT OF TRACE WINDOW IN RA 09750000 C 3. SAVE EACH INPUT TRACE IN RA 09760000 C 09770000 JXXC = IXXC + ITRC - 1 09780000 JXYC = IXYC + ITRC - 1 09790000 JXID = IXID + ITRC - 1 09800000 JXD = IXD + 2 * NF * (ITRC - 1 ) 09810000 JXH = IXH + (ITRC - 1 ) * LEN 09820000 C 09830000 RA(JXXC) = MRXC - MSXC 09840000 RA(JXYC) = MRYC - MSYC 09850000 RA(JXID) = TICD 09860000 C 09870000 C PERFORM FFT OF TRACE 09880000 C 09890000 CALL ARSET ( SA, N, 0. ) 09900000 CALL ARMVE ( OTR(1), SA(1), NS ) 09910000 CALL S2DFT2 ( M, SA, *360 ) 09920000 IS = 2 * IF1 - 1 09930000 CALL ARMVE ( SA(IS), RA(JXD), 2 * NF ) 09940000 360 CONTINUE 09950000 C 09960000 CALL SCOPY ( LEN, OH, 1, RA(JXH), 1 ) 09970000 C 09980000 RETURN 09990000 C 10000000 C SAFF3D3 ENTRY STARTS HERE 10010000 C******************************************************************* 10020000 C******************************************************************* 10030000 C 10040000 ENTRY SAFF3D3 ( OH, OTR, VEL, PASS, IABORT, RA, SA ) 10050000 C 10060000 C******************************************************************* 10070000 C******************************************************************* 10080000 C 10090000 PASS = NO 10100000 C 10110000 C CHECK FOR OUT OF RANGE GATHER 10120000 C 10130000 IF (IRANGE .EQ. 1) RETURN 10140000 C 10150000 C=======================================================================10160000 C 10170000 C IF OUTPUTTING TRACES (JTRC > 0) THEN DO NOT APPLY FILTER 10180000 C 10190000 C=======================================================================10200000 C 10210000 IF (JTRC .LE. 0) THEN 10220000 C 10230000 C LOOP ON OUTPUT TRACES: 10240000 C 10250000 C 1. DETERMINE WHICH INPUT TRACES CONTRIBUTE (SAFF3DC) 10260000 C 2. APPLY FAN FILTER FOR ALL FREQUENCIES (SAFF3DD/SAFF3DE) 10270000 C 10280000 C=======================================================================10290000 C 10300000 C WORK AREAS IN SA: 10310000 C 10320000 C SA(ISTN) - ARRAY TO HOLD INPUT TRACE NUMBERS (ITRC) 10330000 C SA(ISDX) - ARRAY TO HOLD DIFFERENTIAL OFFSETS (ITRC) 10340000 C SA(ISAD) - ARRAY TO HOLD FILTERED DATA (2*NF*ITRC) 10350000 C SA(ISA1) - ARRAY 1 FOR SCALAR PRODUCT (2*ITRC) 10360000 C SA(ISA2) - ARRAY 2 FOR SCALAR PRODUCT (2*NF*MAX(NTIN)) 10370000 C 10380000 ISTN = 1 10390000 ISDX = ISTN + ITRC 10400000 ISAD = ISDX + ITRC 10410000 ISA1 = ISAD + 2 * NF * ITRC 10420000 ISA2 = ISA1 + 2 * ITRC 10430000 C 10440000 C LOOP OVER TRACES IN CURRENT GATHER 10450000 C 10460000 DO 400 KTRC = 1, ITRC 10470000 C 10480000 IF (RA(IXID + KTRC - 1) .EQ. 1) THEN 10490000 C 10500000 C ----------------------------------------------------------------------10510000 C 10520000 C DETERMINE INPUT TRACES CONTRIBUTING TO OUTPUT TRACE KTRC 10530000 C 10540000 CALL SAFF3DC ( KTRC, ITRC, RA(IXXC), RA(IXYC), RA(IXID), 10550000 + RA(IXXX), POX, NTIN, ICT, SA(ISTN), SA(ISDX) ) 10560000 C 10570000 C ----------------------------------------------------------------------10580000 C 10590000 C FOR EACH FREQUENCY, APPLY THE FAN FILTER 10600000 C TO ESTIMATE THE NOISE 10610000 C 10620000 KSAD = ISAD + 2 * NF * (KTRC - 1 ) 10630000 C 10640000 C IF PHASE DISTORTION REDUCTION IS TO BE APPLIED CALL SAFF3DD 10650000 C 10660000 IF (PDR .EQ. 1) THEN 10670000 CALL SAFF3DD ( RA(IXD), RA(IXG), NXTAB, NF, RA(IXDX), 10680000 + RA(IXXX), RA(IXSC), NTIN, ICT, SA(ISTN), SA(ISDX), 10690000 + SA(ISA1), SA(ISA2), SA(KSAD) ) 10700000 C 10710000 ELSE 10720000 C 10730000 C IF NO PHASE DISTORTION REDUCTION IS TO BE APPLIED CALL SAFF3DE 10740000 C 10750000 CALL SAFF3DE ( RA(IXD), RA(IXG), NXTAB, NF, RA(IXDX), 10760000 + RA(IXXX), RA(IXSC), NTIN, ICT, SA(ISTN), SA(ISDX), 10770000 + SA(ISA1), SA(ISA2), SA(KSAD) ) 10780000 C 10790000 ENDIF 10800000 C 10810000 C ----------------------------------------------------------------------10820000 C 10830000 ENDIF 10840000 400 CONTINUE 10850000 C 10860000 C MOVE NOISE ESTIMATES FROM SA(ISAD) INTO RA(IXD) 10870000 C 10880000 CALL SCOPY ( 2 * NF * ITRC, SA(ISAD), 1, RA(IXD), 1 ) 10890000 C 10900000 C***********************************************************************10910000 C***********************************************************************10920000 C 10930000 C OUTPUT TRACES IN THIS AREA 10940000 C 10950000 C***********************************************************************10960000 C***********************************************************************10970000 C 10980000 C INCREMENT THE OUTPUT TRACE COUNT 10990000 C 11000000 ENDIF 11010000 JTRC = JTRC + 1 11020000 PASS = YES3 11030000 IF (JTRC .EQ. ITRC) PASS = YES 11040000 C 11050000 C MOVE TRACE AND HEADER FROM RA 11060000 C 11070000 JXH = IXH + (JTRC - 1 ) * LEN 11080000 CALL SCOPY ( LEN, RA(JXH), 1, OH, 1 ) 11090000 C 11100000 C IF A DEAD TRACE THEN ZERO OUT THE OUTPUT TRACE 11110000 C 11120000 CALL USRTHV ( OH, 'THTICD ', TICD ) 11130000 C 11140000 IF (TICD .NE. 1) THEN 11150000 CALL SCOPY ( NS, ZERO, 0, OTR, 1 ) 11160000 RETURN 11170000 ENDIF 11180000 C 11190000 C FORM OUTPUT TRACE 11200000 C 11210000 JXD = IXD + 2 * NF * (JTRC - 1 ) 11220000 CALL SAFF3DF ( OTR, NS, RA(JXD), NF, IF1, SA, M, N, OSW ) 11230000 C 11240000 C REAPPLY MUTE (ZERO OUT DOWN TO THE FIRST LIVE VALUE) 11250000 C 11260000 CALL USRTHV ( OH, 'THFLV ', IFLV ) 11270000 IF (IFLV .GT. 1) CALL SCOPY ( IFLV - 1, ZERO, 0, OTR, 1 ) 11280000 C 11290000 RETURN 11300000 C 11310000 END 11320000