CTITLESADMFK -- APPLY DIP MOVEOUT CORRECTION 00010001 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00020000 CA AUTHOR L. B. LIN 00030000 CA DESIGNER L. B. LIN 00040000 CA LANGUAGE FORTRAN 00050000 CA SYSTEM IBM AND CRAY 00060000 CA WRITTEN 11/20/85 00070000 C REVISED 09/02/87 ESN FOR CONVERSION TO THE IBM. 00080000 CA 00090000 CA 00100000 CA 00110000 CA SADMFK TRANSFORMS THE NMO-CORRECTED OFFSET SECTION TO F-K DOMAIN 00120000 CA AND TRANSFORMS BACK TO OBTAIN DIP MOVEOUT CORRECTED ZERO-OFFSET 00130000 CA TIME SECTION. 00140000 CA 00150000 CA 00160000 CA CALL SADMFK (ITMNH, NT, NW, DW, MX, NKX, ND, 00170000 CA * WORKX, WORKT, D, AKX, P, ITMN, 00180000 CA * INDX, FRA, WORKR, WORKJ, WORKR1, 00190000 CA * WORKR2, WORKJ1, WORKJ2, CWORK, DWORK) 00200000 CA 00210000 CA INPUTS: 00220000 CA ITMNH - FIRST LIVE VALUE OF THE INPUT TIME SECTION (I4) 00230000 CA NT - NUMBER OF SAMPLES (I4) 00240000 CA NW - FFT NUMBER CORRESPONDING TO NT (I4) 00250000 CA DW - DELTA OMEGA (R4) 00260000 CA MX - NUMBER OF TRACES OF THE INPUT SECTION (I4) 00270000 CA NKX - FFT NUMBER CORRESPONDING TO MX (I4) 00280000 CA ND - NUMBER OF DIP SAMPLES (I4) 00290000 CA WORKX - WORK ARRAY FOR SPACE TRANSFORM (R4) 00300000 CA WORKT - WORK ARRAY FOR TIME TRANSFORM (R4) 00310000 CA D - ARRAY OF DIP SAMPLES (R4) 00320000 CA AKX - ARRAY OF K-VALUES (R4) 00330000 CA P - WAVE FIELD (R4) 00340000 CA ITMN - MININUM TIME ARRAY (I4) 00350000 CA INDX - INDEX ARRAY FOR TIME AXIS MAPPING (I4) 00360000 CA FRA - INTERPOLATION FACTOR FOR CONSTRUCTING A FULL (R4) 00370000 CA T0 AXIS 00380000 CA WORK* - WORK ARRAYS (R4) 00390000 CA 00400000 CA OUTPUT: 00410000 CA P - DIP MOVEOUT CORRECTED ZERO-OFFSET SECTION (R4) 00420000 CA 00430000 CA 00440000 C 00450000 C 00460000 SUBROUTINE SADMFK (ITMNH, NT, NW, DW, MX, NKX, ND, 00470000 * WORKX, WORKT, D, AKX, P, ITMN, 00480000 * INDX, FRA, WORKR, WORKJ, WORKR1, 00490000 * WORKR2, WORKJ1, WORKJ2, CWORK, DWORK) 00500000 C 00510000 C INTEGER ARRAYS -- INPUT 00520001 C 00530001 INTEGER INDX (NT,1) 00540001 INTEGER ITMN (1) 00550001 C 00560001 C REAL ARRAYS -- INPUT 00570001 C 00580001 REAL AKX (1) 00590001 REAL D (1) 00600001 REAL FRA (NT,1) 00610001 REAL P (NT,1) 00620001 REAL WORKJ (2) 00630001 REAL WORKJ1 (1) 00640001 REAL WORKJ2 (1) 00650001 REAL WORKR (2) 00660001 REAL WORKR1 (1) 00670001 REAL WORKR2 (1) 00680001 C 00690000 C COMPLEX ARRAYS -- INPUT 00700001 C 00710001 COMPLEX CWORK (1) 00720001 COMPLEX DWORK (1) 00730001 C 00740001 C COMPLEX VARIABLES -- LOCAL 00750001 C 00760001 COMPLEX C1 00770001 COMPLEX C2 00780001 C 00790000 C INITIALIZATION 00800001 C 00810001 NT1 = NT + 1 00820000 NW2 = NW + 2 00830000 NWD21 = NW/2 + 1 00840000 MX1 = MX + 1 00850000 NKX2 = NKX + 2 00860000 NKXD21 = NKX/2 + 1 00870000 C 00880000 C***** TRANSFORM NMO-CORRECTED WAVE FIELD TO WAVE-NUMBER DOMAIN 00890000 C (1) PN(T,X) ==> PN(T,KX) 00900000 C 00910000 DO 120 IT = ITMNH, NT 00920000 C 00930000 DO 100 IX = 1, MX 00940000 100 WORKR(IX) = P(IT,IX) 00950000 C 00960000 DO 110 IX = MX1, NKX2 00970000 110 WORKR(IX) = 0. 00980000 C 00990000 CALL RCFFT2 (0, -1, NKX, WORKR, WORKX, CWORK) 01000000 CALL SCOPY (NKX2, CWORK, 1, P(IT,1), NT) 01010001 120 CONTINUE 01020001 C 01030000 C****** MAP THE TN-TIME AXIS TO T0-TIME AXIS 01040000 C (2) PN(TN,KX) ==> P0(T0,KX) 01050000 C 01060000 DO 250 IKX = 1, NKXD21 01070000 IKXR = (IKX-1) * 2 + 1 01080000 IKXJ = IKXR + 1 01090000 C 01100000 C CALL SCOPY (NT, P(1,IKXR), 1, WORKR, 1) 01110001 CALL ARMVE (P(1,IKXR), WORKR, NT) 01120001 C CALL SCOPY (NT, P(1,IKXJ), 1, WORKJ, 1) 01130001 CALL ARMVE (P(1,IKXJ), WORKJ, NT) 01140001 C 01150000 WORKR(NT1) = 0. 01160000 WORKJ(NT1) = 0. 01170000 CALL ARSET (DWORK, NW*2, 0.) 01180000 C 01190000 C***** CONSTRUCT COMPLETE P0(T0,KX) AND PERFORM INTEGRATION BY FFT 01200000 C (3) P0(T0,KX) ==> P0(W0,KX) 01210000 C 01220000 DO 230 ID = ND, 1, -1 01230000 C 01240000 C -------- P0D(T,KX) 01250000 C 01260000 ITBEG = ITMN(ID) 01270000 MT = NT - ITBEG + 1 01280000 IWMIN = IFIX (AKX(IKX) / D(ID+1) / DW) + 1 01290000 IF (IWMIN .GE. NWD21) GO TO 230 01300000 IWMAX = MIN0 (NW2 - IWMIN, NW) 01310000 CALL ARSET (CWORK, NW*2, 0.) 01320000 C 01330000 C 01340000 IF (ID .EQ. 1) THEN 01350000 C 01360000 DO 210 IT = ITBEG, NT 01370000 210 CWORK(IT) = CMPLX (WORKR(IT), WORKJ(IT)) 01380000 C 01390000 ELSE 01400000 C 01410000 CALL GATHER (MT,WORKR1(ITBEG),WORKR(1),INDX(ITBEG,ID)) 01420000 CALL GATHER (MT,WORKR2(ITBEG),WORKR(2),INDX(ITBEG,ID)) 01430000 CALL GATHER (MT,WORKJ1(ITBEG),WORKJ(1),INDX(ITBEG,ID)) 01440000 CALL GATHER (MT,WORKJ2(ITBEG),WORKJ(2),INDX(ITBEG,ID)) 01450000 C 01460000 DO 220 IT = ITBEG, NT 01470000 C1 = CMPLX (WORKR1(IT), WORKJ1(IT)) 01480000 C2 = CMPLX (WORKR2(IT), WORKJ2(IT)) 01490000 XF2 = FRA(IT, ID) 01500000 220 CWORK(IT) = C1 + XF2 * (C2-C1) 01510000 C 01520000 ENDIF 01530000 C 01540000 C 01550000 C -------- P0D(W,KX) 01560000 C 01570000 CALL CFFT2 (0, +1, NW, CWORK, WORKT, CWORK) 01580000 C 01590000 C -------- PUT P0D(W,KX) TO APPROPRIATE W RANGE OF P0(W,KX) 01600000 C 01610000 C CALL CCOPY (IWMAX-IWMIN+1,CWORK(IWMIN),1,DWORK(IWMIN),1) 01620000 C1 CALL CCOPY (IWMAX-IWMIN-1,CWORK(IWMIN+1),1,DWORK(IWMIN+1),1) 01630001 CALL ARMVE (CWORK(IWMIN+1), DWORK(IWMIN+1), 2*(IWMAX-IWMIN-1)) 01640001 C 01650000 DWORK(IWMIN) = .5 * (DWORK(IWMIN)+CWORK(IWMIN)) 01660000 DWORK(IWMAX) = .5 * (DWORK(IWMAX)+CWORK(IWMAX)) 01670000 230 CONTINUE 01680000 C 01690000 C INVERSE TRANSFORM TO ZERO-OFFSET WAVE FIELD P0(T0,KX) 01700000 C (4) P0(W0,KX) ==> P0(T0,KX) 01710000 C 01720000 C 01730000 CALL CFFT2 (0, -1, NW, DWORK, WORKT, DWORK) 01740000 C 01750000 DO 250 IT = ITMNH, NT 01760000 P(IT,IKXR) = REAL (DWORK(IT)) 01770000 250 P(IT,IKXJ) = AIMAG(DWORK(IT)) 01780000 C 01790000 C INVERSE TRANSFORM TO ZERO-OFFSET WAVE FIELD P0(T0,X) 01800000 C (5) P0(T0,KX) ==> P0(T0,X) 01810000 C 01820000 C 01830000 DO 300 IT = ITMNH, NT 01840000 C 01850000 CALL SCOPY (NKX2, P(IT,1), NT, CWORK(1), 1) 01860000 C 01870000 CALL CRFFT2 (0, +1, NKX, CWORK, WORKX, WORKR) 01880000 C 01890000 C 300 CALL SCOPY (MX, WORKR, 1, P(IT,1), NT) 01900001 DO 280 IX = 1, MX 01910001 280 P(IT,IX) = WORKR(IX) 01920001 300 CONTINUE 01930001 C 01940000 RETURN 01950000 C 01960001 END 01970000