CTITLESADM3D0 - KIRCHHOFF 3-D DMO C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA CA CA DESIGNER JAMES SUN CA AUTHOR JAMES SUN CA LANGUAGE FORTRAN 77 CA SYSTEM CRAY AND IBM CA WRITTEN 12/03/87 CA C REVISED 02/06/90 JCS COPIED FROM ORIGINAL DM3D AND MADE C CHANGES TO USE CRAIG BEASLEY'S C AMPLITUDE WEIGHTING AND ANTI- C ALIASING FREQUENCY FILTER PLUS SOME C ADDITIONAL CHANGES C REVISED 03/16/90 JCS CHANGED TO SINC INSTEAD FFT FOR C BANDPASS FILTER C REVISED 03/28/90 JCS MOVE TRACE TO BIN CENTER THEN DMO C REVISED 04/25/90 JCS CHANGE THE AZIMUTHAL TO ALONG THE C INLINE, IF DF9=99999 CODED C CORRECT ERROR IN DM3DI C REVISED 05/02/90 JCS IMPLEMENT V(Z)-DMO C REVISED 08/06/90 JCS ADD USER INPUT PARAMETER 'MXAPER' C FOR MAXIMUM CROSSLINE APERTURE C (THIS ALLOWS THE PROGRAM TO C CONTINEOUSLY OUTPUT TRACES THAT C EXHAUST THE INPUT APERTURE) C REVISED 08/16/90 JCS HARDWIRE PROCESSING MODE TO 'Y' C REVISED 09/14/90 JCS CORRECT ICTR CONTROL C REVISED 10/01/90 JCS ADD AMXIMUM APERTURE CONTROL C REVISED 11/28/90 JCS CORRECT ERROR IN SADM3D2 (NEED TO C ALWAYS RETRIVE FLV) C REVISED 12/03/90 JCS CORRECT ERROR IN SADM3DF/G/X/Y C ROUTINES: CHANGE DX, DY IN THE C WEIGHTING INTO ABS(DX), ABS(DY) C REVISED 12/06/90 JCS CORRECT ERROR IN SADM3DF (DO 140) C REVISED 12/07/90 JCS CHANGE MX=NINT(0.6*AMX) C CHANGE MY=NINT(0.6*AMY) C REVISED 12/31/90 JCS USE RCFFT2/CRFFT2 IN SADM3DL C REVISED 03/13/91 JCS CORRECT BUG IN SADM3D3: C WHEN USE MXAPER OPTION, AS THE C PROGRAM STARTS OUTPUT TRACES BEYOND C THE APERTURE, THE CURRENT HEADER C MATRIX RA(KV) NEEDS TO BE WRITTEN C TO DISK BEFORE READ IN NEW ONE C REVISED 07/16/91 JCS CORRECT ERROR IN SADM3D3 (DO 2180) C REVISED 12/17/91 JJC MODIFIED TO MEET SPARC STANDARDS. C REVISED 01/07/92 JJC SET NHST TO ONE IF IFOLD EQUAL TO C ZERO FOR STACK OPTION. C C C PURPOSE: KIRCHHOFF 3-D DMO C INPUT: 3-D PRESTACK DATA SET C OUTPUT: STACKED SECTION OR UNSTACKED TRACE AT SPECIFIED LOCATIONS CA CA CALLING PROCEDURE: CA SUBROUTINE SADM3D0(OH,ICC,AUTO3,IABORT,RA ,IRA) CA C CALLING ARGUMENTS CA CA IN/OUT OH TRACE HEADER CA INPUT ICC THE NUMBER OF WORDS OF RESERVED AREA I4 CA INPUT AUTO3 AUTOMATIC BOUNDARY DETECTION I4 CA IN/OUT IABORT ERROR TERMINATION FLAG I4 CA INPUT RA ADDRESS OF THE FIRST ELEMENT OF RESERVED R4 CA INPUT IRA SAME AS RA I4 C C C ===================================================================== C C C PROCESS DM3D -- KIRCHHOFF 3-D DMO C C C DATA CARD (1) -- DEFINES PROCESSING PARAMETERS C C C NO. OF CARDS: REQUIRED = 1 ALLOWED = 1 C REQ OR OPT C DF COLS DEFINITION OR DEFAULT C -- ----- ---------- ----------- C 1 1- 4 'DM3D' | REQ | C 2 - 5 PROCESS NUMBER | 0 | C 3 - 6 NOT USED | | C 4 - 7 PROCESSING MODE |NOTE DF4 | C 'S' = SHOTPOINT NUMBER | | C 'D' = DEPTHPOINT NUMBER | | C 'O' = OFFSET DISTANCE | | C 'F' = FILE NUMBER | | C 'Y' = 3-D LINE NUMBER | | C 5 8-10 NOT USED | | C 6 11-15 STARTING DEPTH POINT | REQ | C 7 16-20 ENDING DEPTH POINT | REQ | C 8 21-25 DEPTH POINT SPACING (FT OR M) | REQ | C 9 26-30 3D LINE SPACING (FT OR M) | REQ | C 10 31-35 ESTIMATED MAXIMUM TRUE DIP IN THE DATA (DEG) | REQ | C 11 36-40 MINIMUM VELOCITY (FT/SEC OR M/SEC) | REQ | C 12 41-45 HIGH-CUT FREQUENCY (HZ) | 60 | C 13 46-50 FOR PROGRAMMER USE (IDF) | 10 | C 14 51-55 NOT USED | | C 15 56-60 MAXIMUM DMO CROSSLINE HALF APERTURE (3D LINE) | 9999 | C 16 61-65 FOR PROGRAMMER USE (MEMORY) | 16000 | C 17 66-70 STARTING LINE NUMBER | REQ | C 18 71-75 ENDING LINE NUMBER | REQ | C 19 76-80 OUTPUT TRACE SCALING FLAG | +1 | C +1 : NORMALIZED TO THE INPUT; RE-APPLY MUTE | | C +2 : NO RESCALING; RE-APPLY MUTE | | C -1 : NORMALIZED TO THE INPUT; NO MUTE REAPPLIED | | C -2 : NO RESCALING; NO MUTE REAPPLIED | | C |_________| C DF NOTES: C -- ------ C C C *** NOTE *** C DF6, DF7, DF17, AND DF18 WILL BE IGNORED IF CARD (3) C ('VLA' CARD) IS SPECIFIED. C C C 4 ALTHOUGH THE DATA CAN BE IN ANY MODE WITHIN A 3-D LINE, BUT C THEY HAVE TO BE SORTED INTO 3-D LINE SEQUENTIAL MODE. C C 8 FLOATING POINT ALLOWED. C C C 9 FOR A 2-D DATASET, THIS FIELD DEFINES THE CROSSLINE WIDTH OF C THIS 2-D LINE (DF8 DEFINES THE LENGTH OF EACH CDP BIN ALONG C THE INLINE DIRECTION). ENERGY BEING DMO'ED OUTSIDE THIS WIDTH C WILL NOT BE SUMMED IN. DEFAULT TO DF8 IF NOT SPECIFIED. C FLOATING POINT ALLOWED. C C C ** NOTE ** IF 99999 IS CODED IN DF-9, THEN THE LINE IS TREATED C AS A STRAIGHT LINE. C C 15 THIS DEFINES THE MAXIMUM HALF APERTURE FOR DMO OPERATOR. C THIS NUMBER SHOULD NOT EXCEED : C C 1 MAXIMUM CROSSLINE OFFSET DISTANCE C N = - * --------------------------------- C 2 3D LINE SPACING C C C C DMO OPERATOR SCHEMATIC: C C C 3D LINE ====> C INPUT C TRACE C * | * C * | * C * | * C * | * C *<----- DF15 ------>| * C * | * C * | * C * | * C * | * C * | * C * | * C C ===================================================================== C C C PROCESS DM3D -- KIRCHHOFF 3-D DMO C C C DATA CARD (2) -- DEFINE X-Y COORDINATE OF THREE REFERENCE POINTS C C C NO. OF CARDS: REQUIRED = 3 ALLOWED = 3 C REQ OR OPT C DF COLS DEFINITION OR DEFAULT C -- ----- ---------- ----------- C 1 1- 4 'DM3D' | REQ | C 2 - 5 PROCESS NUMBER | 0 | C 3 - 6 NOT USED | | C 4 - 7 NOT USED | | C 5 8-10 'XYC' | REQ | C 6 11-15 DEPTH POINT NUMBER | REQ | C 7 16-20 3D LINE NUMBER | REQ | C 8 21-30 X-COORDINATE | REQ | C 9 31-40 Y-COORDINATE | REQ | C 12 66-80 NOT USED | | C |_________| C DF NOTES: C -- ------ C C C 5 THREE REFERENCE POINTS ARE REQUIRED TO DEFINE THE 3D LINE AND CDP C ORIENTATION. C FOR A 3-D DATASET (MORE THAN ONE 3-D LINE), THESE THREE POINTS C CAN NOT BE FROM THE SAME 2-D LINE. C FOR A 2-D DATASET, THE PROGRAM STILL REQUIRES THREE POINTS. C BUT THESE THREE POINTS CAN BE FROM THE SAME LINE, OR ONE CAN C GIVES TWO POINTS, AND REPLICATES ONE OF THESE TWO POINT AS THE C THIRD POINT. C C C 8- BE CAREFUL ABOUT THIS CARD, INCORRECT X/Y COORDINATE WILL C 9 PRODUCE INCORRECT RESULT. C VALUES CAN DE COMPUTED FROM FROM THE GM3D OR OBTAINED THROUGH C TRACE HEADER (DPXC,DPYC) OR (MDPX,MDPY). C C C ====================================================================== C C C PROCESS DM3D -- KIRCHHOFF 3-D DMO C C C DATA CARD (3) -- DEFINE 3D LINES AND CDP'S FOR VELOCITY ANALYSIS C C C NO. OF CARDS: REQUIRED = 0 ALLOWED = 1 C REQ OR OPT C DF COLS DEFINITION OR DEFAULT C -- ----- ---------- ----------- C 1 1- 4 'DM3D' | REQ | C 2 - 5 PROCESS NUMBER | 0 | C 3 - 6 NOT USED | | C 4 - 7 NOT USED | | C 5 8-10 'VLA' | REQ | C 6 11-15 STARTING DEPTH POINT NUMBER | REQ | C 7 16-20 ENDING DEPTH POINT NUMBER | REQ | C 8 21-25 DEPTH POINT NUMBER INCREMENT | REQ | C 9 26-30 STARTING 3D LINE NUMBER | REQ | C 10 31-35 ENDING 3D LINE NUMBER | REQ | C 11 36-40 3D LINE NUMBER INCREMENT | REQ | C 12 41-45 OFFSET VALUE FOR FIRST OUTPUT BIN CENTER | REQ | C 13 46-50 OFFSET BIN INCREMENT | REQ | C 14 51-55 TOTAL NUMBER OF OFFSET BINS | REQ | C 15 56-60 NUMBER OF CDP'S TO SUM | 1 | C 16 61-65 NUMBER OF 3D LINES TO SUM | 1 | C 17 66-80 NOT USED | | C |_________| C DF NOTES: C -- ------ C C C 5 THIS CARD IS USED TO DEFINE THE SURFACE LOCATION WHERE THE DMO C TRACES WILL BE OUTPUT. THESE TRACES CAN THEN BE USED FOR THE C DMO VELOCITY ANALYSIS (VELA). TRACES FROM DIFFERENT AZIMUTHAL C ANGLES WILL BE SUMMED INTO THE INLINE DIRECTION. THE OUTPUT C OFFSET DISTANCES ARE DEFINED BY DF12-DF14. C C C 12-FOR EACH VA LOCATION DEFINED BY DF6-DF11, A CDP GATHER WILL BE C 14 PRODUCED. EACH GATHER CONTAINS DF14 OFFSETS STARTING FROM OFFSET C DISTANCE DF12 AND INCREMENTING BY DF13. C C C 15 NUMBER OF CONSECUTIVE CDPS TO BE SUMMED IN EACH ANALYSIS. C C C 16 NUMBER OF CONSECUTIVE 3D LINES TO BE SUMMED IN EACH ANALYSIS. C C C ====================================================================== C C C *** PROCESSING PROCEDURE *** C C C STEP 1 -- DETERMINE DMO VELOCITY FIELD C C C VF3D INITIAL VELOCITY FIELD C C C READ C C C NMOC APPLY NMO WITH A NOMINAL VELOCITY FIELD C C C DM3D (W/VLA) 3-D DMO AT DESIRED VA LOCATIONS C C C OMN REMOVE NMO C C C VELA DETERMINE DMO VELOCITY FIELD C C C STEP 2 -- PRODUCE 3-D DMO STACKED TRACES C C C VF3D 3-D DMO VELOCITY FIELD FROM STEP 1 C C C READ C C C NMOC REAPPLY NMO TO THE ORIGINAL PRESTACK TRACES C C C DM3D (W/O VLA) 3-D DMO STACK! C C C WRIT C C C ====================================================================== C EJECT C C C FORMAT OF INPUT PARAMETER RECORDS C C C ****** FIRST RECORD, PROCESSING PARAMETERS ************ C C C WORD 1 WORD 2 WORD 3 WORD 4 WORD 5 WORD 6 WORD 7 WORD 8 C |_______|________|_______|_______|_______|_______|_______|_______| C | DM3D | PROCESS| PTS | NOT | NOT | # OF | NOT | NOT | C |_______|_NUMBER_|_______|__USED_|__USED_|_PARMS_|__USED_|__USED_| C C C WORD 9 WORD 10 WORD 11 WORD 12 WORD 13 WORD 14 WORD 15 WORD 16 C |_______|________|_______|_______|_______|_______|_______|_______| C | IXBEG | IXEND | DX | DY | IDIP | CDPNA | LNNOA | IXA | C |_______|________|_______|_______|_______|_______|_______|_______| C C C WORD 17 WORD 18 WORD 19 WORD 20 WORD 21 WORD 22 WORD 23 WORD 24 C |_______|________|_______|_______|_______|_______|_______|_______| C | IYA | CDPNB | LNNOB | IXB | IYB | CDPNC | LNNOC | IXC | C |_______|________|_______|_______|_______|_______|_______|_______| C C C WORD 25 WORD 26 WORD 27 WORD 28 WORD 29 WORD 30 WORD 31 WORD 32 C |_______|________|_______|_______|_______|_______|_______|_______| C | IYC | IYBEG | IYEND | IVMIN | IVDBEG| IVDEND| IVDINC| IVLBEG| C |_______|________|_______|_______|_______|_______|_______|_______| C C C WORD 33 WORD 34 WORD 35 WORD 36 WORD 37 WORD 38 WORD 39 WORD 40 C |_______|________|_______|_______|_______|_______|_______|_______| C | IVLEND| IVLINC | IVOBEG| IVOINC| NVO | NXSUM | NYSUM | ISFLG | C |_______|________|_______|_______|_______|_______|_______|_______| C C C WORD 41 WORD 42 WORD 43 WORD 44 WORD 45 WORD 46 .......WORD 104 C |_______|________|_______|_______|_______|_______|.......|_______| C | MEMORY| IFHI | IDF | ICTR | IVFLAG| MXAPER|.......| NOT | C |_______|________|_______|_______|_______|_______|.......|__USED_| C C C======================================================================= C EJECT C C C LOCAL ARRAYS (INTERNAL TO SUBROUTINE). C C C DATTR ( 96) = ARRAY FOR ATTRIBUTES OF DATA I4 C DENTRY ( 104) = ARRAY FOR STORAGE OF LOCAL PARAMETERS I4 C ACDPN ( 3) = ARRAY FOR STORAGE OF CDP NO. OF REF. PTS. R4 C ALNNO ( 3) = ARRAY FOR STORAGE OF 3D LINE NO OF REF. PTS. R4 C AX0 ( 3) = ARRAY FOR STORAGE OF X COORDINATE OF REF. PTS R4 C AY0 ( 3) = ARRAY FOR STORAGE OF Y COORDINATE OF REF. PTS R4 C C C LOCAL VARIABLES AND CONSTANTS (INTERNAL TO SUBROUTINE). C C C DT = TIME INTERVAL IN MS. R4 C DX = DEPTH POINT SPACING IN FEET R4 C DY = LINE SPACING IN FEET R4 C IDIP = ESTIMATED MAXIMUM TRUE DIP I4 C IDX = DEPTH POINT SPACING IN FT. I4 C IDY = 3D LINE SPACING IN FT. I4 C IVDBEG = STARTING DEPTH POINT FOR VELOCITY ANALYSIS(VA) I4 C IVDEND = ENDING DEPTH POINT FOR VA I4 C IVDINC = DEPTH POINT INCREMENT FOR VA I4 C IVLBEG = STARTING 3D LINE NUMBER FOR VA I4 C IVLEND = ENDING 3D LINE NUMBER FOR VA I4 C IVLINC = INCREMENT OF 3D LINE NUMBER FOR VA I4 C IVOBEG = STARTING OFFSET DISTANCE FOR VA I4 C IVOINC = INCREMENT OF OFFSET DISTANCE FOR VA I4 C IXBEG = STARTING DEPTH POINT NUMBER I4 C IXEND = ENDING DEPTH POINT NUMBER I4 C IYBEG = STARTING LINE NUMBER I4 C IYEND = ENDING LINE NUMBER I4 C N2W = NUMBER USED TO FFT NT TRACES (NT .LE. 2**N2W) I4 C NW = TOTAL NUMBER OF FREQUENCIESS (NW .EQ. 2**N2W) I4 C NWD2 = NUMBER OF POSITIVE FREQUECIES INCLUDING NYQUIST I4 C NWD21 = NUMBER OF POSITIVE FREQUECIES INC. NYQUIST & ZERO. I4 C NT = NUMBER OF TRACES I4 C NX = NUMBER OF DEPTH POINTS I4 C NXSUM = NUMBER OF CDP TRACES TO SUM I4 C NY = NUMBER OF LINES I4 C NYSUM = NUMBER OF LINES TO SUM I4 C NVO = NUMBER OF OFFSET DISTANCES TO OUTPUT I4 C NVD = NUMBER OF DEPTH POINTS TO OUTPUT I4 C NVL = NUMBER OF LINES TO OUTPUT I4 C C C C C SUBROUTINE SADM3D0(OH,ICC,AUTO3,IABORT,RA ,IRA) C C IMPLICIT INTEGER (A-Z) C C DIMENSION OH(1), OTR(1), RA(1), SA(1), VEL(1), IRA(1) C C CHARACTER*80 CARD C C C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 8/01/90 COMMON /P/ STARTP ( 2) , M00000( 102) COMMON /P/ KPNA COMMON /P/ KPRNO , M00420( 5) COMMON /P/ KPWRKS COMMON /P/ KPWRKD COMMON /P/ KPWKS2 COMMON /P/ KPWKD2 , M00456( 16) COMMON /P/ KPMITF COMMON /P/ KPPRNT , M00528( 2) COMMON /P/ KPBUGF , M00540( 224) COMMON /P/ PROTAB ( 2) COMMON /P/ ENDP C COMMON /SYSTEM/ SYSTEM,SYBYPW,SYLOCF C C REAL A REAL ACDPN REAL AENTRY REAL AI REAL ALNNO REAL ALOG REAL ANF REAL ANORM REAL ANT1 REAL ARG REAL ATHETA REAL AX0 REAL AY0 REAL B REAL BBPER REAL C REAL CTHETA REAL DDNAME REAL DF REAL DPXI REAL DPXO REAL DPYI REAL DPYO REAL DT REAL DW REAL DX REAL DY REAL FC REAL FCDPN REAL FHI REAL FIX0 REAL FIY0 REAL FLNNO REAL FLOAT REAL HXO REAL HYO REAL OTR REAL PI REAL PI2 REAL RA REAL RXC REAL RXCO REAL RYC REAL RYCO REAL SA REAL SCALE REAL SCALEW REAL SINA REAL SNRM2 REAL SRXC REAL SRXCO REAL SRYC REAL SRYCO REAL STHETA REAL THETA REAL TMP REAL TMP1 REAL VEL REAL VMIN REAL W0 REAL XA REAL XAO REAL XB REAL XBO REAL XC REAL XCO REAL YA REAL YAO REAL YB REAL YBO REAL YC REAL YCO C C DIMENSION DENTRY ( 104) DIMENSION AENTRY ( 104) DIMENSION DATTR ( 96) C C DIMENSION ACDPN ( 3) DIMENSION ALNNO ( 3) DIMENSION AX0 ( 3) DIMENSION AY0 ( 3) C C COMMON /HEAD/ ORTN,CDPN,CDPT,TICD,XDST,NS,SI,SSP,FN,THL,LNNO COMMON /USER/ SLOCAL(50),ULOCAL(220) C C EQUIVALENCE (ACDPN , ULOCAL( 1)) EQUIVALENCE (ALNNO , ULOCAL( 4)) EQUIVALENCE (ANORM , ULOCAL( 7)) EQUIVALENCE (ANT1 , ULOCAL( 8)) EQUIVALENCE (ATHETA , ULOCAL( 9)) EQUIVALENCE (AX0 , ULOCAL( 10)) EQUIVALENCE (AY0 , ULOCAL( 13)) EQUIVALENCE (CTHETA , ULOCAL( 16)) C C EQUIVALENCE (DDNAME , ULOCAL( 17)) C EQUIVALENCE (DF , ULOCAL( 18)) EQUIVALENCE (DPXI , ULOCAL( 19)) EQUIVALENCE (DPXO , ULOCAL( 20)) EQUIVALENCE (DPYI , ULOCAL( 21)) EQUIVALENCE (DPYO , ULOCAL( 22)) EQUIVALENCE (DT , ULOCAL( 23)) EQUIVALENCE (DW , ULOCAL( 24)) EQUIVALENCE (DX , ULOCAL( 25)) EQUIVALENCE (DY , ULOCAL( 26)) EQUIVALENCE (FC , ULOCAL( 27)) EQUIVALENCE (FHI , ULOCAL( 28)) EQUIVALENCE (ANF , ULOCAL( 29)) EQUIVALENCE (HXO , ULOCAL( 30)) EQUIVALENCE (HYO , ULOCAL( 31)) EQUIVALENCE (IBF1 , ULOCAL( 32)) EQUIVALENCE (ICDPN1 , ULOCAL( 33)) EQUIVALENCE (ICDPN2 , ULOCAL( 34)) EQUIVALENCE (IDIP , ULOCAL( 35)) EQUIVALENCE (IDLFLG , ULOCAL( 36)) EQUIVALENCE (IDPDE , ULOCAL( 37)) EQUIVALENCE (IDPEL , ULOCAL( 38)) EQUIVALENCE (IDPXC , ULOCAL( 39)) EQUIVALENCE (IDPYC , ULOCAL( 40)) EQUIVALENCE (IDT , ULOCAL( 41)) EQUIVALENCE (IDXV0 , ULOCAL( 42)) EQUIVALENCE (IDYV0 , ULOCAL( 43)) EQUIVALENCE (IER , ULOCAL( 44)) EQUIVALENCE (IEREF , ULOCAL( 45)) EQUIVALENCE (IERIN , ULOCAL( 46)) EQUIVALENCE (IERN , ULOCAL( 47)) EQUIVALENCE (IERR , ULOCAL( 48)) EQUIVALENCE (IF1 , ULOCAL( 49)) EQUIVALENCE (IFHI , ULOCAL( 50)) EQUIVALENCE (NF1 , ULOCAL( 51)) EQUIVALENCE (IFLV , ULOCAL( 52)) EQUIVALENCE (IFOLD , ULOCAL( 53)) EQUIVALENCE (INNER , ULOCAL( 54)) EQUIVALENCE (IOFLAG , ULOCAL( 55)) EQUIVALENCE (IPR , ULOCAL( 56)) EQUIVALENCE (IRXC , ULOCAL( 57)) EQUIVALENCE (IRYC , ULOCAL( 58)) EQUIVALENCE (ISEQDA , ULOCAL( 59)) EQUIVALENCE (ISFLG , ULOCAL( 60)) EQUIVALENCE (ISMDE , ULOCAL( 61)) EQUIVALENCE (ISR , ULOCAL( 62)) EQUIVALENCE (ISRXC , ULOCAL( 63)) EQUIVALENCE (ISRYC , ULOCAL( 64)) EQUIVALENCE (ISWV , ULOCAL( 65)) EQUIVALENCE (IUSCD , ULOCAL( 66)) EQUIVALENCE (IVD , ULOCAL( 67)) EQUIVALENCE (IVDBEG , ULOCAL( 68)) EQUIVALENCE (IVDEND , ULOCAL( 69)) EQUIVALENCE (IVDINC , ULOCAL( 70)) EQUIVALENCE (IVL , ULOCAL( 71)) EQUIVALENCE (IVLBEG , ULOCAL( 72)) EQUIVALENCE (IVLEND , ULOCAL( 73)) EQUIVALENCE (IVLHD , ULOCAL( 74)) EQUIVALENCE (IVLINC , ULOCAL( 75)) EQUIVALENCE (IVMIN , ULOCAL( 76)) EQUIVALENCE (IVO , ULOCAL( 77)) EQUIVALENCE (IVOBEG , ULOCAL( 78)) EQUIVALENCE (IVOEND , ULOCAL( 79)) EQUIVALENCE (IVOINC , ULOCAL( 80)) EQUIVALENCE (IWV , ULOCAL( 81)) EQUIVALENCE (IX0 , ULOCAL( 82)) EQUIVALENCE (IXBEG , ULOCAL( 83)) EQUIVALENCE (IXEND , ULOCAL( 84)) EQUIVALENCE (IXIYHD , ULOCAL( 85)) EQUIVALENCE (IXYOUT , ULOCAL( 86)) EQUIVALENCE (IY0 , ULOCAL( 87)) EQUIVALENCE (IY0HD , ULOCAL( 88)) EQUIVALENCE (IYBEG , ULOCAL( 89)) EQUIVALENCE (IYEND , ULOCAL( 90)) EQUIVALENCE (IYFLAG , ULOCAL( 91)) EQUIVALENCE (ICDPN , ULOCAL( 92)) EQUIVALENCE (JFLAG , ULOCAL( 93)) EQUIVALENCE (ILNNO , ULOCAL( 94)) EQUIVALENCE (KA , ULOCAL( 95)) EQUIVALENCE (KB , ULOCAL( 96)) EQUIVALENCE (KC , ULOCAL( 97)) EQUIVALENCE (KD , ULOCAL( 98)) EQUIVALENCE (KE , ULOCAL( 99)) EQUIVALENCE (KF , ULOCAL(100)) C EQUIVALENCE (KG , ULOCAL(101)) EQUIVALENCE (KH , ULOCAL(102)) EQUIVALENCE (KNRA , ULOCAL(103)) EQUIVALENCE (KO , ULOCAL(104)) EQUIVALENCE (KP , ULOCAL(105)) EQUIVALENCE (KQ , ULOCAL(106)) EQUIVALENCE (KR , ULOCAL(107)) EQUIVALENCE (KK1 , ULOCAL(108)) EQUIVALENCE (KK2 , ULOCAL(109)) EQUIVALENCE (KU , ULOCAL(110)) EQUIVALENCE (KV , ULOCAL(111)) EQUIVALENCE (KW , ULOCAL(112)) EQUIVALENCE (KZ , ULOCAL(113)) EQUIVALENCE (LFB , ULOCAL(114)) EQUIVALENCE (KK3 , ULOCAL(115)) EQUIVALENCE (KK4 , ULOCAL(116)) EQUIVALENCE (MUTE , ULOCAL(117)) EQUIVALENCE (KK5 , ULOCAL(118)) EQUIVALENCE (NW2 , ULOCAL(119)) EQUIVALENCE (IVFLAG , ULOCAL(120)) EQUIVALENCE (MXAPER , ULOCAL(121)) EQUIVALENCE (MXSUM , ULOCAL(122)) EQUIVALENCE (MXY , ULOCAL(123)) EQUIVALENCE (MYSUM , ULOCAL(124)) EQUIVALENCE (N2W , ULOCAL(125)) EQUIVALENCE (NF , ULOCAL(126)) EQUIVALENCE (NFA , ULOCAL(127)) EQUIVALENCE (NFB , ULOCAL(128)) EQUIVALENCE (NO , ULOCAL(129)) EQUIVALENCE (NO3 , ULOCAL(130)) EQUIVALENCE (NS24 , ULOCAL(131)) EQUIVALENCE (NT , ULOCAL(132)) EQUIVALENCE (NTOTAL , ULOCAL(133)) EQUIVALENCE (NVD , ULOCAL(134)) EQUIVALENCE (NVL , ULOCAL(135)) EQUIVALENCE (NVO , ULOCAL(136)) EQUIVALENCE (NW , ULOCAL(137)) EQUIVALENCE (NWD2 , ULOCAL(138)) EQUIVALENCE (NWD21 , ULOCAL(139)) EQUIVALENCE (NX , ULOCAL(140)) EQUIVALENCE (NXNY , ULOCAL(141)) EQUIVALENCE (NXSUM , ULOCAL(142)) EQUIVALENCE (NXV , ULOCAL(143)) EQUIVALENCE (NY , ULOCAL(144)) EQUIVALENCE (NYSUM , ULOCAL(145)) EQUIVALENCE (NYV , ULOCAL(146)) EQUIVALENCE (PI , ULOCAL(147)) EQUIVALENCE (PI2 , ULOCAL(148)) EQUIVALENCE (RXC , ULOCAL(149)) EQUIVALENCE (RXCO , ULOCAL(150)) EQUIVALENCE (RYC , ULOCAL(151)) EQUIVALENCE (RYCO , ULOCAL(152)) EQUIVALENCE (SCALE , ULOCAL(153)) EQUIVALENCE (SCALEW , ULOCAL(154)) EQUIVALENCE (SINA , ULOCAL(155)) EQUIVALENCE (SRXC , ULOCAL(156)) EQUIVALENCE (SRXCO , ULOCAL(157)) EQUIVALENCE (SRYC , ULOCAL(158)) EQUIVALENCE (SRYCO , ULOCAL(159)) EQUIVALENCE (STHETA , ULOCAL(160)) EQUIVALENCE (THETA , ULOCAL(161)) EQUIVALENCE (VMIN , ULOCAL(162)) EQUIVALENCE (W0 , ULOCAL(163)) EQUIVALENCE (XA , ULOCAL(164)) EQUIVALENCE (XAO , ULOCAL(165)) EQUIVALENCE (XB , ULOCAL(166)) EQUIVALENCE (XBO , ULOCAL(167)) EQUIVALENCE (XC , ULOCAL(168)) EQUIVALENCE (XCO , ULOCAL(169)) EQUIVALENCE (YA , ULOCAL(170)) EQUIVALENCE (YAO , ULOCAL(171)) EQUIVALENCE (YB , ULOCAL(172)) EQUIVALENCE (YBO , ULOCAL(173)) EQUIVALENCE (YC , ULOCAL(174)) EQUIVALENCE (YCO , ULOCAL(175)) EQUIVALENCE (YES , ULOCAL(176)) EQUIVALENCE (YES3 , ULOCAL(177)) EQUIVALENCE (ICCX , ULOCAL(178)) C EQUIVALENCE (MOP , ULOCAL(179)) EQUIVALENCE (K0 , ULOCAL(180)) EQUIVALENCE (FIX0 , ULOCAL(181)) EQUIVALENCE (FIY0 , ULOCAL(182)) EQUIVALENCE (FCDPN , ULOCAL(183)) EQUIVALENCE (FLNNO , ULOCAL(184)) EQUIVALENCE (IDSK , ULOCAL(185)) EQUIVALENCE (ICTR , ULOCAL(186)) EQUIVALENCE (PSHOT , ULOCAL(187)) C EQUIVALENCE (YFLAG , ULOCAL(211)) EQUIVALENCE (IXYEND , ULOCAL(212)) EQUIVALENCE (KYBEG , ULOCAL(213)) C C C EQUIVALENCE (AENTRY(1),DENTRY(1)) EQUIVALENCE (DCTYP , DENTRY(3)) EQUIVALENCE (NOPAR , DENTRY(6)) EQUIVALENCE (NOCLD , DENTRY(7)) EQUIVALENCE (DATTR(1), DENTRY(9)) C C INTEGER PSHOT(24) C C YES = 0 NO = 1 YES3 = 2 NO3 = 3 C C C C IPR = KPPRNT IABORT = NO ISR = SI/1000 AUTO3 = YES C C==================================================================== C READ INPUT PARAMETERS C==================================================================== C IDA = 1 100 CALL FORP (KPNA, KPRNO, IDA, 104, DENTRY, * 2280 ) IF(S1CPCH (DCTYP, 1, 'PTS', 1, 3) .NE. 0) GO TO 100 C C IXBEG = DATTR( 1) IXEND = DATTR( 2) DX = AENTRY(11) DY = AENTRY(12) IDIP = DATTR( 5) ACDPN(1) = DATTR( 6) ALNNO(1) = DATTR( 7) AX0(1) = DATTR( 8) AY0(1) = DATTR( 9) ACDPN(2) = DATTR(10) ALNNO(2) = DATTR(11) AX0(2) = DATTR(12) AY0(2) = DATTR(13) ACDPN(3) = DATTR(14) ALNNO(3) = DATTR(15) AX0(3) = DATTR(16) AY0(3) = DATTR(17) IYBEG = DATTR(18) IYEND = DATTR(19) IVMIN = DATTR(20) C C IVDBEG = DATTR(21) IVDEND = DATTR(22) IVDINC = DATTR(23) IVLBEG = DATTR(24) IVLEND = DATTR(25) IVLINC = DATTR(26) IVOBEG = DATTR(27) IVOINC = DATTR(28) NVO = DATTR(29) NXSUM = DATTR(30) NYSUM = DATTR(31) ISFLG = DATTR(32) MEMORY = DATTR(33) IFHI = DATTR(34) IDF = DATTR(35) ICTR = DATTR(36) IVFLAG = DATTR(37) MXAPER = DATTR(38) C C IF(DY.EQ.0.) DY=DX C C==================================================================== C IF(NVO.GT.0) ==> VELA OPTION C IF(NVO.EQ.0) ==> STACK OPTION C==================================================================== C C IF(NVO.GT.0) THEN C C IF(IVDEND.EQ.IVDBEG) IVDINC=1 NVD=(IVDEND-IVDBEG)/IVDINC+1 IF(IVLEND.EQ.IVLBEG) IVLINC=1 NVL=(IVLEND-IVLBEG)/IVLINC+1 IVOEND=(NVO-1)*IVOINC+IVOBEG C C MXSUM=NXSUM/2 NXSUM=2*MXSUM+1 MYSUM=NYSUM/2 NYSUM=2*MYSUM+1 C C NXV=IVDEND-IVDBEG+NXSUM NYV=IVLEND-IVLBEG+NYSUM IDXV0=IVDBEG-MXSUM-1 IDYV0=IVLBEG-MYSUM-1 C C WRITE(IPR,8180) IVDBEG,IVDEND,IVDINC,NVD,NXSUM,NXV,IDXV0, + IVLBEG,IVLEND,IVLINC,NVL,NYSUM,NYV,IDYV0, + IVOBEG,IVOEND,IVOINC,NVO ENDIF C C==================================================================== C COORDINATE DEFINITIONS C==================================================================== C DO 120 I=1,3 120 WRITE(IPR,8240) I,ACDPN(I),ALNNO(I),AX0(I),AY0(I) C C IYFLAG=YES IF(ALNNO(1).EQ.ALNNO(2) .AND. ALNNO(2).EQ.ALNNO(3)) THEN IYFLAG=NO ENDIF C C CALL SADM3DM(ACDPN,ALNNO,AX0,A,B,C) C C XA=A*IXBEG+B*IYBEG+C XB=A*IXEND+B*IYBEG+C XC=A*IXBEG+B*IYEND+C C C CALL SADM3DM(ACDPN,ALNNO,AY0,A,B,C) C C YA=A*IXBEG+B*IYBEG+C YB=A*IXEND+B*IYBEG+C YC=A*IXBEG+B*IYEND+C C C WRITE(IPR,8220) IXBEG,IYBEG,XA,YA WRITE(IPR,8220) IXEND,IYBEG,XB,YB WRITE(IPR,8220) IXBEG,IYEND,XC,YC C C PI=3.141592653589793 SINA=SIN(FLOAT(IDIP)*PI/180.) C C IF(XB.EQ.XA) THEN THETA=PI/2. IF(YA.GT.YB) THETA=-THETA ELSE IF(YB.EQ.YA) THEN THETA=0. IF(XA.GT.XB) THETA=PI ELSE THETA=ATAN2(YB-YA,XB-XA) ENDIF C C CTHETA=COS(THETA) STHETA=SIN(THETA) ATHETA=THETA/PI*180. C C XAO = (XA -XA)*CTHETA + (YA -YA)*STHETA YAO = -(XA -XA)*STHETA + (YA -YA)*CTHETA XBO = (XB -XA)*CTHETA + (YB -YA)*STHETA YBO = -(XB -XA)*STHETA + (YB -YA)*CTHETA XCO = (XC -XA)*CTHETA + (YC -YA)*STHETA YCO = -(XC -XA)*STHETA + (YC -YA)*CTHETA C C==================================================================== C MORE INITIALIZATION C==================================================================== C VMIN=IVMIN C C IDT=ISR NT=NS C C DT=IDT*.001 ANT1=NT-2 C C NX=IXEND-IXBEG+1 NY=IYEND-IYBEG+1 IF(YCO.LT.YAO) DY=-DY C C PI2=PI*2. N2W = IFIX(ALOG(FLOAT(NT)*1.00)/ALOG(2.))+1 NW=2**N2W NWD2=NW/2 NWD21=NWD2+1 NW2=NW+2 DW=PI2/DT/FLOAT(NW) C C SCALEW=0.5/FLOAT(NW) C C WRITE(IPR,8040) NX,DX,NY,DY,NT,IDT,NW,MXAPER,ATHETA C C==================================================================== C ANTI-ALIASING FILTER SEGMENT DESIGN C==================================================================== C DF=IDF C C FLO=IFLO C FHI=IFHI CJCS NF=INT(FHI/DF)+1 NF=INT((FHI+0.00001)/DF)+1 DF=FHI/FLOAT(NF) ANF=NF NF1=NF+1 C C MOP=132/IDT C CJCS MOP=INT(.50001/(DF*DT))+1 C C==================================================================== C MEMORY REQUIREMENT (ICC) CALCULATION C==================================================================== C C C NVO = 0 NVO > 0 C ------- ------- C RA(K0)------------------------------------------------- C | A | NT*NX*NY | NT*NVO*NVD*NVL | C KA |----------|------------------|-----------------| C | WSQRT | NWD21 | NWD21 | C KB |----------|------------------|-----------------| C | TSQRT | NT | NT | C KC |----------|------------------|-----------------| C | FCUT | 1001 | 1001 | C KD |----------|------------------|-----------------| C | T0MAX | 1001 | 1001 | C KE |----------|------------------|-----------------| C | STRCH | 1001 | 1001 | C KF |----------|------------------|-----------------| C | WGHT | 1001 | 1001 | C KK1|----------|------------------|-----------------| C | GAMMA | NT | NT | C KK2|----------|------------------|-----------------| C | WORK1 | NT*1001 | NT*1001 | C KH |----------|------------------|-----------------| C | IDXV | | NXV | C KO |----------| |-----------------| C | IDYV | | NYV | C KQ |----------|------------------|-----------------| C | OH | THL | THL | C KR |----------|------------------|-----------------| C | IWC | NF+1 | NF+1 | C KU |----------|------------------|-----------------| C | WORKN | 3*NW+4 | 3*NW+4 | C KV |----------|------------------|-----------------| C | HEADER | NX*7 | NVO*NVD*7 | C KW |----------|------------------|-----------------| C | P | (NT )*(NF+1) | (NT )*(NF+1) | C KZ |----------|------------------|-----------------| C | Q | NW+2 | NW+2 | C KK3|----------|------------------|-----------------| C | WORK2 | NT | NT | C KK4|----------|------------------|-----------------| C | WORK3 | NT | NT | C KK5|----------|------------------|-----------------| C | WORK4 | NT*2 | NT*2 | C KKW|----------|------------------|-----------------| C | WORKQ | NW+2 | NW+2 | C ICC |-----------------------------------------------| C C C IF(NVO.EQ.0) THEN NXNY=NX*NY MXY=NXNY IF(NT*MXY .LE. MEMORY) THEN K0=1 KA=K0+NT*MXY IDSK=NO ELSE KA = 1 IDSK=YES ENDIF KB = KA + NWD21 KC = KB + NT KD = KC + 1001 KE = KD + 1001 KF = KE + 1001 KK1= KF + 1001 KK2= KK1+ NT IF(IVFLAG.EQ.YES) THEN KQ = KK2+ NT*1001 ELSE KQ = KK2+ NT ENDIF KR = KQ + THL KU = KR + NF+1 KV = KU + 3*NW+4 KW = KV + NX*7 KZ = KW + NT*(NF+1) KK3 = KZ + NW+2 KK4 = KK3+ NT KK5 = KK4+ NT KKW = KK5+ NT*2 ICC = KKW+ NW+2 ELSE C C IF1=NVO*NVD MXY=IF1*NVL IF(NT*MXY .LE. MEMORY) THEN K0=1 KA=K0+NT*MXY IDSK=NO ELSE KA = 1 IDSK=YES ENDIF WRITE(IPR,8020) NT*MXY,MEMORY,K0,KA 8020 FORMAT(' NT*MXY,MEMORY,K0,KA =',4I8) KB = KA + NWD21 KC = KB + NT KD = KC + 1001 KE = KD + 1001 KF = KE + 1001 KK1= KF + 1001 KK2= KK1+ NT IF(IVFLAG.EQ.YES) THEN KH = KK2+ NT*1001 ELSE KH = KK2+ NT ENDIF KO = KH + NXV KQ = KO + NYV KR = KQ + THL KU = KR + NF+1 KV = KU + 3*NW+4 KW = KV + IF1*7 KZ = KW + NT*(NF+1) KK3 = KZ + NW+2 KK4 = KK3+ NT KK5 = KK4+ NT KKW = KK5+ NT*2 ICC = KKW+ NW+2 C C ENDIF C C ICCX=ICC KNRA=(ICC*4+1023)/1024 C C WRITE(IPR,7001) K0,KA,KB,KC,KD,KE,KF,KG,KH,KO,KQ,KR,KU,KV,KW,KZ, C + KK1,KK2,KK3,KK4,KK5,KKW,ICC C7001 FORMAT(' K0 =',I8,' KA =',I8,/, C + ' KB =',I8,' KC =',I8,/, C + ' KD =',I8,' KE =',I8,/, C + ' KF =',I8,' KG =',I8,/, C + ' KH =',I8,' KO =',I8,/, C + ' KQ =',I8,' KR =',I8,/, C + ' KU =',I8,' KV =',I8,/, C + ' KW =',I8,' KZ =',I8,/, C + ' KK1=',I8,' KK2=',I8,/, C + ' KK3=',I8,' KK4=',I8,/, C + ' KK5=',I8,' KKW=',I8,/, C + ' ICC=',I8) C C IF(IDSK.EQ.NO) THEN WRITE(IPR,8060) KNRA ELSE WRITE(IPR,8080) KNRA ENDIF IF(ISFLG.EQ.0) THEN WRITE(IPR,8200) ENDIF C C==================================================================== C INITIALIZE COUNTER/FLAG C==================================================================== C IXYOUT=0 NTOTAL=0 NS24=0 JFLAG = 0 YFLAG = 0 C C==================================================================== C RETURN C C C C******************************************************************* C******************************************************************* C ENTRY SADM3D1(OH,OTR,VEL,PASS,IABORT,RA,SA,IRA) C C******************************************************************* C******************************************************************* C C C IABORT = NO C C IF(YFLAG.NE.0) GO TO 800 C C IF(IYFLAG.EQ.NO .AND. LNNO.NE.ALNNO(1)) THEN GO TO 2320 ENDIF C C CALL ARSET(RA,ICCX,0) C C================================================================= C PREPARING DISK FOR OUTPUT TRACES AND NECESSARY HEADERS C================================================================= C IF(NVO .EQ. 0) THEN NFA=NY*NX NFB=7*NY LFB=NX IY0HD=1 ELSE NFA=NVL*NVD*NVO NFB=NVD*7*NVL LFB=NVO CALL SADM3DC(IRA(KH),IRA(KO)) IVLHD=1 ENDIF C C................................................................. C DISK I/O C................................................................. C IF(IDSK.EQ.YES) THEN C C CALL UPAWRK(NFA, NT*4,'A',KPWRKS,KPWRKD,DDNAME,IER,IERN) C C IF(S1CPCH(SYSTEM,1,'CRAY',1,4) .EQ. 0) THEN IBF1=(NT*NFA+511)/512 IBF1=MIN0(500,IBF1) CALL FOISSD(KPWRKS,NT*4,IBF1) ELSE CALL FOISSD(KPWRKS,NT*4) ENDIF C C ISEQDA=1 DO 640 I=1,NFA 640 CALL FOWSSD(KPWRKS,ISEQDA,RA) CALL FOCSD(KPWRKS) CALL FOIDSD(KPWRKD,NT*4) C C ENDIF C C................................................................. C CALL UPAWRK(NFB,LFB*4,'B',KPWKS2,KPWKD2,DDNAME,IER,IERN) C C IF(S1CPCH(SYSTEM,1,'CRAY',1,4) .EQ. 0) THEN IBF1=(NFB*LFB+511)/512 IBF1=MIN0(100,IBF1) CALL FOISSD(KPWKS2,LFB*4,IBF1) ELSE CALL FOISSD(KPWKS2,LFB*4) ENDIF C C IF(NVO .EQ. 0) THEN IKV=KV+NX*5 CALL ARSET(IRA(IKV),NX,99999) ISEQDA=1 DO 660 IY=1,NY IKV=KV DO 660 I7=1,7 CALL FOWSSD(KPWKS2,ISEQDA,IRA(IKV)) 660 IKV=IKV+NX ELSE IKV=KV+NVO*NVD*5 CALL ARSET(IRA(IKV),NVO*NVD,99999) ISEQDA=1 DO 680 IVL=1,NVL IKV=KV DO 680 I7=1,7 DO 680 IVD=1,NVD CALL FOWSSD(KPWKS2,ISEQDA,IRA(IKV)) 680 IKV=IKV+NVO ENDIF C C CALL FOCSD(KPWKS2) CALL FOIDSD(KPWKD2,LFB*4) C C================================================================= C PRE-CALCULATE OPERATOR TABLES C================================================================= C JW=KA DO 700 IW=1,NWD21 TMP=(IW-1)*DW RA(JW)=SQRT(TMP)*SCALEW C RA(JW)=TMP *SCALEW 700 JW=JW+1 C C W0=20.*PI2 RA(KB)=0. JT=KB+1 DO 720 IT=2,NT TMP=1./(2.*W0*(IT-1)*DT) RA(JT)=2.*SQRT(TMP*(2.-TMP)) 720 JT=JT+1 C C BBPER=1./1000. C C RA(KC)=1.E30 RA(KD)=1.E30 RA(KE)=1. RA(KF)=1. JC=KC+1 JD=KD+1 JE=KE+1 JF=KF+1 DO 740 I=2,1001 TMP=(I-1)*BBPER TMP1=1.-TMP RA(JC)=0.5*SQRT(TMP1)**3/(SQRT(TMP)*DT)/DF RA(JD)=2.*SINA*TMP1/(VMIN*SQRT(TMP)*DT) RA(JE)=1./SQRT(TMP1) RA(JF)=RA(JE)**3 C C RA(JF)=1./TMP1**2 C JC=JC+1 JD=JD+1 JE=JE+1 740 JF=JF+1 C CC CALL PTST1R('T0MX',RA(KD),1001,IPR) CC CALL PTST1R('STRH',RA(KE),1001,IPR) C JF=KF+1 DO 760 I=2,1001 AI=SQRT(FLOAT(I-1)*.001) IF(AI .GT. 0.7) THEN ARG=(1.-AI)*PI/0.3 RA(JF)=(1.-COS(ARG))*.5*RA(JF) ENDIF 760 JF=JF+1 C C====================================================================== C HEADER C====================================================================== C CALL SCOPY (THL,OH,1,RA(KQ),1) C C CALL ARSET (RA(KQ),30,0) CALL USSTHV(RA(KQ),'THNS ', NS) CALL USSTHV(RA(KQ),'THSI ', SI) CALL USRTHV( OH,'THUSCD ',IUSCD) CALL USSTHV(RA(KQ),'THUSCD ',IUSCD) CALL USRTHV( OH,'THWV ',IWV ) CALL USSTHV(RA(KQ),'THWV ',IWV ) CALL USRTHV( OH,'THSWV ',ISWV ) CALL USSTHV(RA(KQ),'THSWV ',ISWV ) CALL USRTHV( OH,'THEREF ',IEREF) CALL USSTHV(RA(KQ),'THEREF ',IEREF) CALL USSTHV(RA(KQ),'THTICD ', 1) CALL USSTHV(RA(KQ),'THORTN ', 1) CALL USSTHV(RA(KQ),'THCDPT ', 1) C C==================================================================== C ANTI-ALIASING FILTER SEGMENT DESIGN C==================================================================== C WRITE(IPR,8260) IFHI,NF,DF C C JR=KR FC=0 RA(JR)=1 DO 780 JF=1,NF JR=JR+1 FC=FC+DF IRA(JR)=INT(FC*PI2/DW)+1 IRA(JR)=MIN0(IRA(JR),NWD2) WRITE(IPR,8280) JF+1,FC,IRA(JR) 780 CONTINUE C C C CALL SADM3DO(MOP,RA(KG)) C C====================================================================== C FFT-TABLES C====================================================================== C CALL RCFFT2(1,-1,NW,RA(KW),RA(KU),RA(KW)) C CALL PTST1R('WRKN',RA(KU),3*NW+4,IPR) C C====================================================================== C GAMMA(TN) FOR V(Z)-DMO C====================================================================== C IF(IVFLAG.EQ.YES) THEN C C CALL SADM3DA(RA(KK1),RA(KK2),RA(KK3),RA(KK4),KPNA,KPRNO,DT,IPR, + NT,IVFLAG) C C CALL SADM3DB(RA(KK1),RA(KK2),RA(KE),NT) C C ENDIF C C====================================================================== C WRITE(IPR,8120) C C YFLAG=1 IXYEND=0 IF(NVO.EQ.0) THEN KYBEG=IYBEG ELSE KYBEG=IVLBEG ENDIF C C 800 CONTINUE C C C******************************************************************* C******************************************************************* C ENTRY SADM3D2(OH,OTR,VEL,PASS,IABORT,RA,SA,IRA) C C******************************************************************* C******************************************************************* C C C PASS = NO C C IF(TICD.NE.1) GO TO 1500 C C C C CALL ARSET(RA(KW),NW2*(NF+2),0.) C CALL ARSET(RA(KW),ICCX-KW+1,0.) C C CALL USRTHV(OH,'THSRXC ',ISRXC) CALL USRTHV(OH,'THSRYC ',ISRYC) CALL USRTHV(OH,'THRXC ',IRXC ) CALL USRTHV(OH,'THRYC ',IRYC ) SRXC=ISRXC SRYC=ISRYC RXC=IRXC RYC=IRYC C C RXCO = (RXC-XA)*CTHETA + (RYC-YA)*STHETA RYCO = -(RXC-XA)*STHETA + (RYC-YA)*CTHETA SRXCO = (SRXC-XA)*CTHETA + (SRYC-YA)*STHETA SRYCO = -(SRXC-XA)*STHETA + (SRYC-YA)*CTHETA C C HXO=(RXCO-SRXCO)*.5 HYO=(RYCO-SRYCO)*.5 C C WRITE(IPR,7981) SRXC,SRYC,RXC,RYC C7981 FORMAT(' SRXC ,SRYC ,RXC ,RYC =',4E12.5) C WRITE(IPR,7982) SRXCO,SRYCO,RXCO,RYCO C7982 FORMAT(' SRXCO,SRYCO,RXCO,RYCO =',4E12.5) C IF(NINT(DY).NE.99999) THEN DPXO=(RXCO+SRXCO)*.5 DPYO=(RYCO+SRYCO)*.5 FIX0=DPXO/DX+1. FIY0=DPYO/DY+1. IX0=NINT(FIX0) IY0=NINT(FIY0) FCDPN=FIX0-1+IXBEG FLNNO=FIY0-1+IYBEG ICDPN=NINT(FCDPN) ILNNO=NINT(FLNNO) C C FIX0=IX0 FIY0=IY0 FCDPN=ICDPN FLNNO=ILNNO C C WRITE(IPR,7983) DPXO,DPYO,IX0,IY0,ICDPN,ILNNO C7983 FORMAT(' DPXO,DPYO =',2E12.5,' IX0,IY0,ICDPN,ILNNO =',4I5) C ELSE IX0=CDPN-IXBEG+1 IY0=LNNO-IYBEG+1 ICDPN=CDPN ILNNO=LNNO FIX0=IX0 FIY0=IY0 FCDPN=CDPN FLNNO=LNNO C C HXO=XDST*0.5 HYO=0. C C ENDIF C CALL USRTHV(OH,'THFLV ',IFLV) C C C======================================== C STACK OPTION C======================================== C IF(NVO.EQ.0) THEN C C IF(IX0.LT.1 .OR. IX0.GT.NX) GO TO 1380 IF(IY0.LT.1 .OR. IY0.GT.NY) GO TO 1380 C C IF(IY0.NE.IY0HD) THEN C C IF(IYFLAG.EQ.NO .AND. LNNO.NE.ALNNO(1)) THEN GO TO 2320 ENDIF C C ISEQDA=(IY0HD-1)*7+1 IKV=KV DO 1300 I7=1,7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 1300 IKV=IKV+NX IY0HD=IY0 ISEQDA=(IY0HD-1)*7+1 IKV=KV DO 1320 I7=1,7 CALL FORDSD(KPWKD2,ISEQDA,RA(IKV)) 1320 IKV=IKV+NX ENDIF C C CALL USRTHV(OH,'THDPDE ',IDPDE) CALL USRTHV(OH,'THSMDE ',ISMDE) CALL USRTHV(OH,'THDPEL ',IDPEL) IF(ISFLG.GT.0) THEN CALL USRTHV(OH,'THFLV ',IFLV) C JFLV=FLOAT(XDST)/VMIN/DT+1 C IFLV=MAX0(IFLV,JFLV) DO 1340 IT=NT,1,-1 1340 IF(OTR(IT) .NE. 0.0) GO TO 1360 1360 INNER=IT+1 ELSE IFLV=1 INNER=NT ENDIF C C IKV=KV+IX0-1 RA(IKV)=RA(IKV)+SNRM2(NT,OTR,1) C C IRA(KV+(2-1)*NX+IX0-1)=IRA(KV+(2-1)*NX+IX0-1)+1 IRA(KV+(3-1)*NX+IX0-1)=IDPDE IRA(KV+(4-1)*NX+IX0-1)=ISMDE IRA(KV+(5-1)*NX+IX0-1)=IDPEL IRA(KV+(6-1)*NX+IX0-1)=MIN0(IRA(KV+(6-1)*NX+IX0-1),IFLV) IRA(KV+(7-1)*NX+IX0-1)=MAX0(IRA(KV+(7-1)*NX+IX0-1),INNER) C C 1380 CONTINUE IF(IDSK.EQ.YES) THEN CALL SADM3DF(HXO,HYO,IX0,IY0,IFLV,RA(KB), + RA(KC),RA(KD),RA(KE),RA(KF), + RA(KW),RA(KZ),RA(KK1),RA(KK2),RA(KK3),RA(KK4),RA(KK5),OTR, + NT,KPWRKD,IABORT,RA(KU),RA(KKW)) ELSE CALL SADM3DX(HXO,HYO,IX0,IY0,IFLV,RA(K0),RA(KB), + RA(KC),RA(KD),RA(KE),RA(KF), + RA(KW),RA(KZ),RA(KK1),RA(KK2),RA(KK3),RA(KK4),RA(KK5),OTR, + NT,NX,NY,IABORT,RA(KU),RA(KKW)) ENDIF C C IF(IABORT.EQ.YES) GO TO 2300 C C======================================== C VELA OPTION C======================================== C ELSE C C IVO=NINT(FLOAT(XDST-IVOBEG)/FLOAT(IVOINC))+1 IF(IVO.LT.1 .OR. IVO.GT.NVO) GO TO 1480 C C JCDPN=CDPN-IDXV0 IF(JCDPN.LT.1 .OR. JCDPN.GT.NXV) GO TO 1480 IVD=IRA(KH+JCDPN-1) IF(IVD.EQ.-9999) GO TO 1480 C C JLNNO=LNNO-IDYV0 IF(JLNNO.LT.1 .OR. JLNNO.GT.NYV) GO TO 1480 IVL=IRA(KO+JLNNO-1) IF(IVL.EQ.-9999) GO TO 1480 C C IDLFLG=0 IF( (MOD(LNNO-IVLBEG,IVLINC).NE.0) + .OR. (MOD(CDPN-IVDBEG,IVDINC).NE.0) ) THEN IDLFLG=1 ENDIF C C IF(IVL.NE.IVLHD) THEN C C IF(IYFLAG.EQ.NO .AND. LNNO.NE.ALNNO(1)) THEN GO TO 2320 ENDIF C C ISEQDA=(IVLHD-1)*NVD*7+1 IKV=KV DO 1400 I=1,NVD*7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 1400 IKV=IKV+NVO C WRITE(IPR,7766) IVLHD C7766 FORMAT(' *2-W* IVLHD =',I5) C CALL PTST1I('MUTE',RA(KV+NVO*NVD*5),NVO*NVD,IPR) IVLHD=IVL ISEQDA=(IVL-1)*NVD*7+1 IKV=KV DO 1420 I=1,NVD*7 CALL FORDSD(KPWKD2,ISEQDA,RA(IKV)) 1420 IKV=IKV+NVO C WRITE(IPR,7767) IVLHD C7767 FORMAT(' *2-R* IVLHD =',I5) C CALL PTST1I('MUTE',RA(KV+NVO*NVD*5),NVO*NVD,IPR) ENDIF C C CALL USRTHV(OH,'THDPDE ',IDPDE) CALL USRTHV(OH,'THSMDE ',ISMDE) CALL USRTHV(OH,'THDPEL ',IDPEL) IF(ISFLG.GT.0) THEN CALL USRTHV(OH,'THFLV ',IFLV) C JFLV=FLOAT(XDST)/VMIN/DT+1 C IFLV=MAX0(IFLV,JFLV) DO 1440 IT=NT,1,-1 1440 IF(OTR(IT) .NE. 0.0) GO TO 1460 1460 INNER=IT+1 ELSE IFLV=1 INNER=NT ENDIF C C IKV=KV+(IVD-1)*NVO+IVO-1 RA(IKV)=RA(IKV)+SNRM2(NT,OTR,1) CALL SADM3DN(IVO,IVD,IDPDE,ISMDE,IDPEL,IFLV,INNER,RA(KV), + NVO,NVD,IDLFLG) C C 1480 CONTINUE IF(IDSK.EQ.YES) THEN CALL SADM3DG(HXO,HYO,IX0,IY0,IVO,IFLV,RA(KB), + RA(KC),RA(KD),RA(KE),RA(KF),RA(KH),RA(KO), + RA(KW),RA(KZ),RA(KK1),RA(KK2),RA(KK3),RA(KK4),RA(KK5),OTR, + NT,KPWRKD,IABORT,RA(KU),RA(KKW)) ELSE CALL SADM3DY(HXO,HYO,IX0,IY0,IVO,IFLV,RA(K0),RA(KB), + RA(KC),RA(KD),RA(KE),RA(KF),RA(KH),RA(KO), + RA(KW),RA(KZ),RA(KK1),RA(KK2),RA(KK3),RA(KK4),RA(KK5),OTR, + NT,NVO,NVD,NVL,IABORT,RA(KU),RA(KKW)) C C CALL SCOPY(NT,OTR,1,Q(MOP),1) C ENDIF C C IF(IABORT.EQ.YES) GO TO 2300 C C======================================== C ENDIF C C======================================== C 1500 CONTINUE C C RETURN C C******************************************************************* C******************************************************************* C ENTRY SADM3D3(OH,OTR,VEL,PASS,IABORT,RA,SA,IRA) C C******************************************************************* C******************************************************************* C C C PASS = NO C C IF(IXYOUT.LT.MXY) GO TO 2020 IF(JFLAG.EQ.0) THEN IF(NS24.GT.0) WRITE(IPR,8140) NTOTAL,(PSHOT(JS),JS=1,NS24) WRITE(IPR,8100) NTOTAL C C IF(IDSK.EQ.YES) THEN CALL FOCDD(KPWRKD) CALL UGUWRK(KPWRKS,KPWRKD,IERR,IERIN) ENDIF C C CALL FOCDD(KPWKD2) CALL UGUWRK(KPWKS2,KPWKD2,IERR,IERIN) JFLAG=1 END IF GO TO 2260 C C==================================================================== C OUTPUT TRACES C==================================================================== C 2020 CONTINUE IF(IXYOUT.LT.IXYEND) GO TO 2030 C IF(NVO.EQ.0) THEN IF(KPMITF.EQ.0) THEN IXYEND=MXY GO TO 2030 ELSE IF(LNNO-KYBEG+1 .GE. MXAPER) THEN IXYEND=(LNNO-KYBEG+1-MXAPER+1)*NX GO TO 2030 ENDIF ELSE IF(KPMITF.EQ.0) THEN IXYEND=MXY GO TO 2030 ELSE IF(LNNO-(KYBEG+MYSUM)+1 .GE. MXAPER) THEN IXYEND=((KYBEG-IVLBEG)/IVLINC+1)*NVD*NVO KYBEG=KYBEG+IVLINC GO TO 2030 ENDIF ENDIF GO TO 2270 C C 2030 CONTINUE IXYOUT=IXYOUT+1 C C*************************************************** C IF(IXYOUT.EQ.1) THEN C C....................................... C IF(NVO.EQ.0) THEN ISEQDA=(IY0HD-1)*7+1 IKV=KV DO 2040 I7=1,7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 2040 IKV=IKV+NX ELSE ISEQDA=(IVLHD-1)*NVD*7+1 IKV=KV DO 2060 I7=1,NVD*7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 2060 IKV=IKV+NVO C WRITE(IPR,7768) IVLHD C7768 FORMAT(' *3-W* IVLHD =',I5) C CALL PTST1I('MUTE',RA(KV+NVO*NVD*5),NVO*NVD,IPR) ENDIF C C....................................... C ENDIF C C*************************************************** C IF(NVO.GT.0) GO TO 2160 C C************************ C STACK OPTION C************************ C C CALL SADM3DR(OTR,OH,RA,IRA,KPWRKD,KPWKD2,PASS,THL) C KLNNO=(IXYOUT-1)/NX+IYBEG KCDPN=IXYOUT-(KLNNO-IYBEG)*NX+IXBEG-1 C C IY0=KLNNO-IYBEG+1 IX0=KCDPN-IXBEG+1 IF(IY0.NE.IY0HD) THEN ISEQDA=(IY0HD-1)*7+1 IKV=KV DO 2070 I7=1,7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 2070 IKV=IKV+NX C IY0HD=IY0 ISEQDA=(IY0-1)*7+1 IKV=KV DO 2080 I7=1,7 CALL FORDSD(KPWKD2,ISEQDA,RA(IKV)) 2080 IKV=IKV+NX ENDIF IXIYHD=KV+IX0-1 ANORM=RA(IXIYHD)/FLOAT(NT) IFOLD=IRA(IXIYHD+NX) IDPDE=IRA(IXIYHD+NX*2) ISMDE=IRA(IXIYHD+NX*3) IDPEL=IRA(IXIYHD+NX*4) MUTE=IRA(IXIYHD+NX*5) INNER=IRA(IXIYHD+NX*6) C C IF(IDSK.EQ.YES) THEN ISEQDA=IXYOUT CALL FORDSD(KPWRKD,ISEQDA,OTR) ELSE ISEQDA=(IXYOUT-1)*NT+1 CALL SCOPY(NT,RA(ISEQDA),1,OTR,1) ENDIF C C IF(KCDPN.EQ.IXBEG) THEN C C IF(IXYOUT.NE.1 .AND. NS24.GT.0) THEN WRITE(IPR,8140) NTOTAL,(PSHOT(JS),JS=1,NS24) ENDIF CALL SADM3DH(RA(KV),NX,IXBEG,ICDPN1,ICDPN2,IPR) IF(ICTR.NE.0) THEN ICDPN1=IXBEG ICDPN2=IXEND C MUTE=1 C INNER=NT+1 ENDIF WRITE(IPR,8160) KLNNO,ICDPN1,ICDPN2 NS24=0 C C ENDIF C C IF(ICTR.NE.0) THEN MUTE=1 INNER=NT+1 ENDIF C C IF(KCDPN.LT.ICDPN1 .OR. KCDPN.GT.ICDPN2) THEN PASS = NO3 GO TO 2260 ENDIF C C PASS=YES3 NTOTAL=NTOTAL+1 C C CALL SADM3DI(OTR,RA(KA),RA(KZ),RA(KU)) C C MUTE=MIN0(MUTE,NT+1) INNER=MAX0(MUTE,INNER) C C DO 2100 IT=1,MUTE-1 2100 OTR(IT)=0. DO 2120 IT=INNER,NT 2120 OTR(IT)=0. C C IF(IABS(ISFLG).EQ.1) THEN SCALE=SNRM2(NT,OTR,1)*IFOLD IF(SCALE.NE.0.) SCALE=ANORM/SCALE CALL SSCAL(NT,SCALE,OTR,1) ENDIF C C WRITE(IPR,9981) IXYOUT,KCDPN,KLNNO C CALL PTST1R('OTR ',OTR,NT,IPR) C C C---------------------------------------------------------------------- C UPDATE OUTPUT HEADER C---------------------------------------------------------------------- C CALL SCOPY(THL,RA(KQ),1,OH,1) C C CALL USSTHV(OH,'THCDPN ',KCDPN) CALL USSTHV(OH,'THLNNO ',KLNNO) CALL USSTHV(OH,'THFLV ',MUTE) CALL USSTHV(OH,'THDPDE ',IDPDE) CALL USSTHV(OH,'THSMDE ',ISMDE) CALL USSTHV(OH,'THDPEL ',IDPEL) IF (IFOLD .LE. 0) IFOLD = 1 CALL USSTHV(OH,'THNHST ',IFOLD) C C DPXO=(KCDPN-IXBEG)*DX DPYO=(KLNNO-IYBEG)*DY C C DPXI= DPXO*CTHETA - DPYO*STHETA + XA DPYI= +DPXO*STHETA + DPYO*CTHETA + YA C C IDPXC=DPXI+0.5 IDPYC=DPYI+0.5 CALL USSTHV(OH,'THDPXC ',IDPXC) CALL USSTHV(OH,'THDPYC ',IDPYC) CALL USSTHV(OH,'THMDPX ',IDPXC) CALL USSTHV(OH,'THMDPY ',IDPYC) CALL USSTHV(OH,'THSRXC ',IDPXC) CALL USSTHV(OH,'THSRYC ',IDPYC) CALL USSTHV(OH,'THRXC ',IDPXC) CALL USSTHV(OH,'THRYC ',IDPYC) C C NS24=NS24+1 PSHOT(NS24)=KCDPN IF(NS24.LT.24.AND.IXYOUT.LT.NXNY) GO TO 2140 WRITE(IPR,8140) NTOTAL,(PSHOT(JS),JS=1,NS24) NS24=0 C C 2140 CONTINUE GO TO 2260 C C************************ C VELA OPTION C************************ C 2160 CONTINUE C CALL SADM3DS(OTR,OH,RA,IRA,KPWRKD,KPWKD2,PASS,THL) C C IVL=(IXYOUT-1)/IF1+1 JF1=IXYOUT-(IVL-1)*IF1 IVD=(JF1-1)/NVO+1 IVO=JF1-(IVD-1)*NVO C C IF(IVL.NE.IVLHD) THEN ISEQDA=(IVLHD-1)*NVD*7+1 IKV=KV DO 2170 I=1,NVD*7 CALL FOWDSD(KPWKD2,ISEQDA,RA(IKV)) 2170 IKV=IKV+NVO C IVLHD=IVL ISEQDA=(IVL-1)*NVD*7+1 IKV=KV DO 2180 I=1,NVD*7 CALL FORDSD(KPWKD2,ISEQDA,RA(IKV)) 2180 IKV=IKV+NVO C WRITE(IPR,7769) IVLHD C7769 FORMAT(' *3-R* IVLHD =',I5) C CALL PTST1I('MUTE',RA(KV+NVO*NVD*5),NVO*NVD,IPR) ENDIF IXIYHD=KV+(IVD-1)*NVO+IVO-1 ANORM=RA(IXIYHD)/FLOAT(NT) IFOLD=IRA(IXIYHD+IF1) IDPDE=IRA(IXIYHD+IF1*2) ISMDE=IRA(IXIYHD+IF1*3) IDPEL=IRA(IXIYHD+IF1*4) MUTE=IRA(IXIYHD+IF1*5) INNER=IRA(IXIYHD+IF1*6) C C IF(IVO.EQ.1) IOFLAG=NO C C KLNNO=(IVL-1)*IVLINC+IVLBEG KCDPN=(IVD-1)*IVDINC+IVDBEG KXDST=(IVO-1)*IVOINC+IVOBEG C C IF(IDSK.EQ.YES) THEN ISEQDA=IXYOUT CALL FORDSD(KPWRKD,ISEQDA,OTR) ELSE ISEQDA=(IXYOUT-1)*NT+1 CALL SCOPY(NT,RA(ISEQDA),1,OTR,1) ENDIF C C IF(IVO.EQ.1 .AND. IVD.EQ.1) THEN C C IF(IXYOUT.NE.1 .AND. NS24.GT.0) THEN WRITE(IPR,8140) NTOTAL,(PSHOT(JS),JS=1,NS24) ENDIF CALL SADM3DK(RA(KV),ICDPN1,ICDPN2,NVO,NVD,IVDBEG,IVDEND, + IVDINC,IPR) C C IF(ICTR.NE.0) THEN ICDPN1=IXBEG ICDPN2=IXEND C MUTE=1 C INNER=NT+1 ENDIF C C IF(ICDPN1.LE.ICDPN2) WRITE(IPR,8160) KLNNO,ICDPN1,ICDPN2 NS24=0 C C ENDIF C C C IF(ICTR.NE.0) THEN MUTE=1 INNER=NT+1 ENDIF C C IF(KCDPN.LT.ICDPN1 .OR. KCDPN.GT.ICDPN2 .OR. MUTE.EQ.99999) THEN PASS = NO3 GO TO 2240 ENDIF C C PASS=YES3 IOFLAG=YES NTOTAL=NTOTAL+1 C C CALL SADM3DI(OTR,RA(KA),RA(KZ),RA(KU)) C C MUTE=MIN0(MUTE,NT+1) INNER=MAX0(MUTE,INNER) C C DO 2200 IT=1,MUTE-1 2200 OTR(IT)=0. DO 2220 IT=INNER,NT 2220 OTR(IT)=0. C C IF(IABS(ISFLG).EQ.1) THEN SCALE=SNRM2(NT,OTR,1)*IFOLD IF(SCALE.NE.0.) SCALE=ANORM/SCALE CALL SSCAL(NT,SCALE,OTR,1) ENDIF C C WRITE(IPR,9981) IXYOUT,KCDPN,KLNNO C9981 FORMAT(' IXYOUT,CDPN,LNNO =',3I5) C CALL PTST1R('OTR ',OTR,NT,IPR) C C C---------------------------------------------------------------------- C UPDATE OUTPUT HEADER C---------------------------------------------------------------------- C CALL SCOPY(THL,RA(KQ),1,OH,1) C C CALL USSTHV(OH,'THCDPN ',KCDPN) CALL USSTHV(OH,'THLNNO ',KLNNO) CALL USSTHV(OH,'THFLV ',MUTE) CALL USSTHV(OH,'THXDST ',KXDST) CALL USSTHV(OH,'THFN ',KXDST) CALL USSTHV(OH,'THORTN ',IVO ) CALL USSTHV(OH,'THCDPT ',IVO ) CALL USSTHV(OH,'THDPDE ',IDPDE) CALL USSTHV(OH,'THSMDE ',ISMDE) CALL USSTHV(OH,'THDPEL ',IDPEL) C C WRITE(IPR,7851) KLNNO,KCDPN,IVO,MUTE C7851 FORMAT(' KLNNO,KCDPN,IVO,MUTE =',4I5) C IF(IVO.EQ.1) THEN DPXO=(KCDPN-IXBEG)*DX DPYO=(KLNNO-IYBEG)*DY C C DPXI= DPXO*CTHETA - DPYO*STHETA + XA DPYI= +DPXO*STHETA + DPYO*CTHETA + YA C C IDPXC=DPXI+0.5 IDPYC=DPYI+0.5 ENDIF C C CALL USSTHV(OH,'THDPXC ',IDPXC) CALL USSTHV(OH,'THDPYC ',IDPYC) CALL USSTHV(OH,'THMDPX ',IDPXC) CALL USSTHV(OH,'THMDPY ',IDPYC) C C ISRXC=DPXI-KXDST*.5+0.5 IRXC =DPXI+KXDST*.5+0.5 C ISRXC=DPXI-XDST*.5+0.5 C IRXC =DPXI+XDST*.5+0.5 CALL USSTHV(OH,'THSRXC ',ISRXC) CALL USSTHV(OH,'THSRYC ',IDPYC) CALL USSTHV(OH,'THRXC ',IRXC) CALL USSTHV(OH,'THRYC ',IDPYC) C C 2240 CONTINUE IF(IVO.EQ.NVO .AND. IOFLAG.EQ.YES) THEN NS24=NS24+1 PSHOT(NS24)=KCDPN IF(NS24.LT.24.AND.IXYOUT.LT.MXY) GO TO 2260 WRITE(IPR,8140) NTOTAL,(PSHOT(JS),JS=1,NS24) NS24=0 ENDIF C C===================================================================== C NORMAL EXIT C===================================================================== C 2260 CONTINUE C C IF(IXYOUT.EQ.IXYEND .AND. IXYOUT.NE.MXY) THEN IF(PASS.EQ.YES3) PASS=YES IF(PASS.EQ. NO3) PASS=NO ENDIF C C 2270 CONTINUE RETURN C C===================================================================== C ERROR EXITS C===================================================================== C 2280 WRITE(IPR,8300) GO TO 2340 C C 2300 WRITE(IPR,8320) LNNO,CDPN,HXO,HYO,RXC,RYC,SRXC,SRYC,RXCO,RYCO, + SRXCO,SRYCO,XDST GO TO 2340 C C 2320 WRITE(IPR,8340) ALNNO(1) C C 2340 IABORT = YES C C===================================================================== C FORMAT STATEMENTS C===================================================================== C 8040 FORMAT(/,' *** DM3D REV.12/07/90 ***', + /,' NUMBER OF DEPTH POINTS NX =',I5, + /,' DEPTH POINT SPACING IN FEET DX =',F8.2, + /,' NUMBER OF LINES NY =',I5, + /,' LINE SPACING IN FEET DY =',F8.2, + /,' NUMBER OF SAMPLES NT =',I5, + /,' TIME INTERVAL IN MS DT =',I5, + /,' TOTAL NUMBER OF FREQUENCIES NW =',I5, + /,' MAX. HALF DMO APERTURE (3D LINE) MXAPER =',I5, + /,' THETA =',F8.2) C C 8060 FORMAT(/,' RESERVED AREA REQUIRED, KBYTE =',I6) C C 8080 FORMAT(/,' RESERVED AREA REQUIRED, KBYTE =',I6, + ' DISK I/O INVOKED') C C 8100 FORMAT(/,' TOTAL OUTPUT TRACES =',I6) C C 8120 FORMAT(/,' COUNT DEPTH POINT PROCESSED') C C 8140 FORMAT(1X,I5,1X,6I5,3(2X,6I5)) C C 8160 FORMAT(' 3-D LINE NO. ',I5,' (CDP RANGE:',2I5,')') C C 8180 FORMAT(' DMO PRESTACK TRACES WILL BE OUTPUT FOR:',/, + ' BEGINNING CDP NUMBER IVDBEG =',I5,/, + ' ENDING CDP NUMBER IVDEND =',I5,/, + ' CDP INCREMENT IVDINC =',I5,/, + ' NUMBER OF CDPS TO OUTPUT NVD =',I5,/, + ' NUMBER OF CDP TRACES TO SUM NXSUM =',I5,/, + ' NXV =',I5,/, + ' IDXV0 =',I5,/, + ' BEGINNING LINE NUMBER IVLBEG =',I5,/, + ' ENDING LINE NUMBER IVLEND =',I5,/, + ' INCREMENT OF 3D LINE NUMBER IVLINC =',I5,/, + ' NUMBER OF LINES TO OUTPUT NVL =',I5,/, + ' NUMBER OF LINE TO SUM NYSUM =',I5,/, + ' NYV =',I5,/, + ' IDYV0 =',I5,/, + ' STARTING OFFSET DISTANCE IVOBEG =',I5,/, + ' ENDING OFFSET DISTANCE IVOEND =',I5,/, + ' INCREMENT OF FFSET DISTANCE IVOINC =',I5,/, + ' NUMBER OF OFFSET DIST. TO OUTPUT NVO =',I5,/) C C 8200 FORMAT(' OUTPUT TRACES ENERGY NORMALIED') C C 8220 FORMAT(' (CDPN,LNNO) =',2I5,' X,Y =',2E15.8) C C 8240 FORMAT(' I: ',I3,' ACDPN: ',E15.8,' ALNNO: ',E15.8, + ' AX0: ',E15.8,' AY0: ',E15.8) C C 8260 FORMAT(/,' ** ANTI-ALIASING FILTER PARAMETERS **',/, + ' FHI,NF,DF =',2I5,E12.5) C C 8280 FORMAT(' J =',I3,' F = ',E12.5,' HZ, IWC =',I5) C C 8300 FORMAT(/,' *** FORP(PTS) ERROR @10 ***') C C 8320 FORMAT(/,' *** ERROR IN SADM3DF ***',/, + ' LNNO,CDPN =',2I5,' HX,HY =',2E13.6, + /,' RXC, RYC =',2E13.6, + /,' SRXC, SRYC =',2E13.6, + /,' RXCO, RYCO =',2E13.6, + /,' SRXCO,SRYCO =',2E13.6, + /,' XDST =',I10) C C 8340 FORMAT(/,' *** FATAL ERROR ***', + /,' INPUT CONTAINS MORE THAN ONE 3-D LINES !!!', + /,' THE THREE POINTS FROM XYC CRAD ARE ALL FROM LINE', + F8.1) C C RETURN END