CTITLESADNMA -- DIFFERENTIAL MOVEOUT APPLICATION 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR DANIEL POLAK 00020000 CA DESIGNER DANIEL POLAK 00030000 CA LANGUAGE FORTRAN H 00040000 CA SYSTEM IBM 3081/3033 00050000 CA WRITTEN 03-02-82 00060000 C REVISED 03-26-82 JBC. CORRECTED REVERSE NORMAL MOVEOUT 00070000 C BY APPLYING CORRECTED VELOCITY 00080000 C FUNCTION TO DETERMINE LAST VALID 00090000 C OUTPUT POINT 00100000 C REVISED 04-05-82 ESN. MODIFIED THE DNMO 3838 CODE. 00110000 C REVISED 05-06-82 ESN. ADDED IN A STATIC CAPABILITY. 00120000 C REVISED 10-06-82 ESN. ADDED IN COMMON/APSTAT/ IN PLACE 00130000 C OF COMMON/P/. 00140000 C REVISED 01-06-83 ESN. CORRECTED INTERPOLATION PROBLEM 00150000 C WHEN OFFSETS ARE CLOSE. 00160000 C REVISED 01-20-83 ESN. CORRECTED PROBLEM WHEN ENTIRE TRACE 00170000 C IS ABOVE FIRST VEL CURVE INTERSECTION00180000 C REVISED 08-07-85 RSK. CHANGED MODIFICATIONS TO VPSS CCWS 00190000 C TO CORRESSPOND TO THE OLD FORMAT AND 00200000 C TO THE 31BIT ADDRESSING FORMAT. 00210000 CA 00220000 CA CALL SADNMA (XIN, XOUT, VEL, SAMPR, STAT, NOSAMP, CCW1, CCW2, 00230000 CA * CCW3, CCW4, APUNIT, APDNMO, APNMO, APDOMN, APOMN, 00240000 CA * APPRM1, APPRM2, REJECT, TRACE, WRKDTO, WRKDTX, 00250000 CA * WORKTX) 00260000 CA 00270000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00280000 CA 00290000 CA IN XIN I4 OFFSET DISTANCE OF INPUT TRACE 00300000 CA IN XOUT I4 OFFSET DISTANCE OF OUTPUT TRACE 00310000 CA IN VEL R4 VELOCITY FUNCTION 00320000 CA IN SAMPR R4 SAMPLE INTERVAL IN SECONDS 00330000 CA IN STAT R4 STATIC TO APPLY IN SECONDS 00340000 CA IN NOSAMP I4 NUMBER OF SAMPLES IN THE TRACE 00350000 CA IN CCW1 I4 CCW FOR DNMO OF NORMAL MOVOUT AP TASK 00360000 CA IN CCW2 I4 CCW FOR REST OF NORMAL MOVEOUT TASK 00370000 CA IN CCW3 I4 CCW FOR DOMN OF REVERSE NMO TASK 00380000 CA IN CCW4 I4 CCW FOR REST OF REVERSE NMO TASK 00390000 CA IN APUNIT I4 ARRAY PROCESSOR UNIT NUMBER 00400000 CA IN APDNMO I4 APRL ADDRESS FOR DNMO AP TASK 00410000 CA IN APNMO I4 APRL ADDRESS FOR NORMAL MOVEOUT AP TASK 00420000 CA IN APDOMN I4 APRL ADDRESS FOR DOMN AP TASK 00430000 CA IN APOMN I4 APRL FOR REVERSE NORMAL MOVEOUT AP TASK 00440000 CA IN APPRM1 R4 AP PARAMETERS FOR NORMAL MOVEOUT 00450000 CA IN APPRM2 R4 AP PARAMETERS FOR REVERSE NORMAL MOVEOUT 00460000 CA IN REJECT R4 WORK ARRAY OF LENGTH NOSAMP 00470000 CA IN/OUT TRACE R4 SEISMIC TRACE 00480000 CA IN WRKDTO R4 WORK ARRAY OF LENGTH NOSAMP 00490000 CA IN WRKDTX R4 WORK ARRAY OF LENGTH NOSAMP 00500000 CA IN WORKTX R4 WORK ARRAY OF LENGTH NOSAMP 00510000 CA 00520000 CA 00530000 CA THIS SUBROUTINE APPLIES DIFFERENTIAL NORMAL OR REVERSE NORMAL 00540000 CA MOVEOUT TO THE INPUT TRACE BY EXECUTING THE APPROPRIATE ARRAY 00550000 CA PROCESSOR TASK. THE AP TASKS MUST BE TRANSLATED AND HAVE 00560000 CA THEIR PARAMETERS INITIALIZED PRIOR TO EXECUTION OF THIS 00570000 CA SUBROUTINE. 00580000 CA 00590000 C EJECT 00600000 C 00610000 SUBROUTINE SADNMA (XIN, XOUT, VEL, SAMPR, STAT, NOSAMP, CCW1, 00620000 * CCW2, CCW3, CCW4, APUNIT, APDNMO, APNMO, 00630000 * APDOMN, APOMN, APPRM1, APPRM2, REJECT, TRACE, 00640000 * WRKDTO, WRKDTX, WORKTX) 00650000 C 00660000 IMPLICIT INTEGER (A-Z) 00670000 C 00680000 COMMON /APSTAT/ STATUS 00690000 C 00700000 C INTEGER ARRAYS IN THE PARAMETER LIST 00710000 C 00720000 INTEGER CCW1 (1) 00730000 INTEGER CCW2 (1) 00740000 INTEGER CCW3 (1) 00750000 INTEGER CCW4 (1) 00760000 C 00770000 C REAL ARRAYS IN THE PARAMETER LIST 00780000 C 00790000 REAL APPRM1 (1) 00800000 REAL APPRM2 (1) 00810000 REAL REJECT (1) 00820000 REAL TRACE (1) 00830000 REAL VEL (1) 00840000 REAL WRKDTO (1) 00850000 REAL WRKDTX (1) 00860000 REAL WORKTX (1) 00870000 C 00880000 C REAL VARIABLES 00890000 C 00900000 REAL ASHIFT 00910000 REAL DTMIN / Z3C100000 / 00920000 REAL FXOUT 00930000 REAL SAMPR 00940000 REAL STAT 00950000 REAL TXL 00960000 C 00970000 C PERFORM NORMAL OR REVERSE NORMAL MOVEOUT BASED ON THE DISTANCES 00980000 C 00990000 IF (XOUT - XIN) 100, 300, 200 01000000 C NMO, NONE, OMN 01010000 C 01020000 C***********************************************************************01030000 C 01040000 C APPLY DIFFERENTIAL NORMAL MOVEOUT 01050000 C 01060000 100 STATUS = 0 01070000 APPRM1(1) = XIN 01080000 APPRM1(2) = XOUT 01090000 APPRM1(3) = STAT 01100000 I = LOC(WRKDTX(1)) 01110000 CCCCCCCALL S1MVCH (I, 2, CCW1(9), 2, 3) 01120000 CALL CCWMOD (I,CCW1(9)) 01130000 I = LOC(WORKTX(1)) 01140000 CCCCCCCALL S1MVCH (I, 2, CCW1(11), 2, 3) 01150000 CALL CCWMOD (I,CCW1(11)) 01160000 I = LOC(REJECT(1)) 01170000 CCCCCCCALL S1MVCH (I, 2, CCW1(13), 2, 3) 01180000 CALL CCWMOD (I,CCW1(13)) 01190000 C 01200000 CALL VPSS (APUNIT, 'EXCW', APDNMO) 01210000 IF (STATUS .LT. 0) GO TO 100 01220000 C 01230000 C INTERPOLATE AND COLLAPSE THE DELTA T ARRAY 01240000 C 01250000 K = WORKTX(1) / SAMPR + 1.0 01260000 IF (K .LE. 0) GO TO 120 01270000 IF (K .GT. NOSAMP) K = NOSAMP 01280000 DO 110 I = 1, K 01290000 110 WRKDTO(I) = WRKDTX(1) 01300000 120 J = 0 01310000 TXL = K * SAMPR 01320000 K = K + 1 01330000 IF (K .GT. NOSAMP) GO TO 150 01340000 DO 140 I = K, NOSAMP 01350000 130 J = J + 1 01360000 IF (J .GT. NOSAMP) GO TO 135 01370000 IF (TXL .GT. WORKTX(J)) GO TO 130 01380000 WRKDTO(I) = WRKDTX(J-1) + (TXL-WORKTX(J-1)) * REJECT(J) 01390000 IF (WRKDTO(I) .LE. 0.0) WRKDTO(I) = DTMIN 01400000 GO TO 140 01410000 135 WRKDTO(I) = WRKDTO(I-1) 01420000 140 TXL = TXL + SAMPR 01430000 150 CONTINUE 01440000 C 01450000 C COMPLETE DIFFERENTIAL NORMAL MOVEOUT IN THE 3838 01460000 C 01470000 160 STATUS = 0 01480000 I = LOC(TRACE(1)) 01490000 CCCCCCCALL S1MVCH (I, 2, CCW2(7), 2, 3) 01500000 CALL CCWMOD (I,CCW2(7)) 01510000 CCCCCCCALL S1MVCH (I, 2, CCW2(11), 2, 3) 01520000 CALL CCWMOD (I,CCW2(11)) 01530000 I = LOC(WRKDTO(1)) 01540000 CCCCCCCALL S1MVCH (I, 2, CCW2(9), 2, 3) 01550000 CALL CCWMOD (I,CCW2(9)) 01560000 C 01570000 CALL VPSS (APUNIT, 'EXCW', APNMO) 01580000 IF (STATUS .LT. 0) GO TO 160 01590000 C 01600000 GO TO 400 01610000 C 01620000 C***********************************************************************01630000 C 01640000 C APPLY DIFFERENTIAL REVERSE NORMAL MOVEOUT 01650000 C 01660000 200 STATUS = 0 01670000 APPRM2(1) = XIN 01680000 APPRM2(2) = XOUT 01690000 ASHIFT = STAT / SAMPR 01700000 APPRM2(3) = ASHIFT 01710000 I = LOC(WRKDTX(1)) 01720000 CCCCCCCALL S1MVCH (I, 2, CCW3(9), 2, 3) 01730000 CALL CCWMOD (I,CCW3(9)) 01740000 I = LOC(WORKTX(1)) 01750000 CCCCCCCALL S1MVCH (I, 2, CCW3(11), 2, 3) 01760000 CALL CCWMOD (I,CCW3(11)) 01770000 I = LOC(REJECT(1)) 01780000 CCCCCCCALL S1MVCH (I, 2, CCW3(13), 2, 3) 01790000 CALL CCWMOD (I,CCW3(13)) 01800000 C 01810000 CALL VPSS (APUNIT, 'EXCW', APDOMN) 01820000 IF (STATUS .LT. 0) GO TO 200 01830000 C 01840000 C INTERPOLATE AND COLLAPSE THE DELTA T ARRAY 01850000 C 01860000 K = WORKTX(1) / 1.0 + 1.0 01870000 IF (K .LE. 0) GO TO 220 01880000 IF (K .GT. NOSAMP) K = NOSAMP 01890000 DO 210 I = 1, K 01900000 210 WRKDTO(I) = WRKDTX(1) + K - I 01910000 220 J = 0 01920000 TXL = K * 1.0 01930000 K = K + 1 01940000 IF (K .GT. NOSAMP) GO TO 250 01950000 DO 240 I = K, NOSAMP 01960000 230 J = J + 1 01970000 IF (J .GT. NOSAMP) GO TO 235 01980000 IF (TXL .GT. WORKTX(J)) GO TO 230 01990000 WRKDTO(I) = WRKDTX(J-1) + (TXL-WORKTX(J-1)) * REJECT(J) 02000000 IF (WRKDTO(I) .LE. 0.0) WRKDTO(I) = DTMIN 02010000 GO TO 240 02020000 235 WRKDTO(I) = WRKDTO(I-1) 02030000 240 TXL = TXL + 1.0 02040000 250 CONTINUE 02050000 C 02060000 C COMPLETE DIFFERENTIAL REVERSE NORMAL MOVEOUT IN THE 3838 02070000 C 02080000 260 STATUS = 0 02090000 I = LOC(TRACE(1)) 02100000 CCCCCCCALL S1MVCH (I, 2, CCW4(7), 2, 3) 02110000 CALL CCWMOD (I,CCW4(7)) 02120000 I = LOC(WRKDTO(1)) 02130000 CCCCCCCALL S1MVCH (I, 2, CCW4(9), 2, 3) 02140000 CALL CCWMOD (I,CCW4(9)) 02150000 I = LOC(WORKTX(1)) 02160000 CCCCCCCALL S1MVCH (I, 2, CCW4(11), 2, 3) 02170000 CALL CCWMOD (I,CCW4(11)) 02180000 C 02190000 CALL VPSS (APUNIT, 'EXCW', APOMN) 02200000 IF (STATUS .LT. 0) GO TO 260 02210000 C 02220000 C FIND THE LAST VALID OUTPUT POINT 02230000 C 02240000 J = NOSAMP - 1 02250000 K = 0 02260000 FXOUT = XOUT 02270000 TX = FXOUT / WORKTX(1) + 2 + ASHIFT 02280000 IF (TX .GT. (NOSAMP+1)) TX = NOSAMP + 1 02290000 IF (TX .GE. (NOSAMP+1)) GO TO 295 02300000 C 02310000 270 TXL = FXOUT / WORKTX(J+1) 02320000 TXL = SQRT (J * J + TXL * TXL) + ASHIFT 02330000 N = TXL 02340000 IF (N .LE. NOSAMP-1) GO TO 280 02350000 J = J - 1 02360000 K = K + 1 02370000 IF (J .GE. 0) GO TO 270 02380000 C 02390000 C COMPRESS THE ARRAY PROCESSOR OUTPUT INTO THE OUTPUT TRACE 02400000 C 02410000 280 L = NOSAMP 02420000 IF (K .GT. 0) GO TO 286 02430000 IF (N .EQ. NOSAMP-1) GO TO 286 02440000 J = NOSAMP - 1 - N 02450000 DO 283 I = 1, J 02460000 283 TRACE(NOSAMP-I+1) = 0.0 02470000 L = NOSAMP - J 02480000 286 CONTINUE 02490000 C 02500000 C '23' CONSTANT BELOW IS LENGTH OF APPRM2 FRONT 02510000 C INFORMATION AND NEEDS TO BE CONSISTENT WITH 02520000 C ANY CHANGES MADE TO THE AP CODE 02530000 C 02540000 INDEX = NOSAMP + 23 02550000 C 02560000 IEND = NOSAMP - K - 1 02570000 IF (IEND .LE. 0) GO TO 293 02580000 DO 290 I = 1, IEND 02590000 J = NOSAMP - I - K 02600000 IF (L .LT. TX) GO TO 295 02610000 IF (REJECT(J) .LE. 0.0) GO TO 290 02620000 TRACE(L) = APPRM2(INDEX+J-1) 02630000 L = L - 1 02640000 C 02650000 290 CONTINUE 02660000 C 02670000 293 TX = L + 1 02680000 C 02690000 295 CALL ARSET (TRACE, TX-1, 0.0) 02700000 C 02710000 GO TO 400 02720000 C 02730000 C STATIC SHIFT ONLY 02740000 C 02750000 300 CONTINUE 02760000 SAMPI = SAMPR * 1000.0 + 0.5 02770000 RLEN = NOSAMP * SAMPI 02780000 IF (STAT .GE. 0.0) STATI = STAT * 1000.0 + 0.5 02790000 IF (STAT .LT. 0.0) STATI = STAT * 1000.0 - 0.5 02800000 IF (STATI .EQ. 0) GO TO 400 02810000 C 02820000 CALL S1STAT (TRACE, RLEN, SAMPI, STATI, 1, 0) 02830000 C 02840000 400 CONTINUE 02850000 RETURN 02860000 END 02870000