CTITLESAEQMO0 -- EQUAL-MOVEOUT MULTIPLE SUPPRESSION
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
C
C    DESIGNER             P C LUH
C    AUTHOR               P C LUH
C    LANGUAGE             S/370 FORTRAN H
C    SYSTEM               IBM / CRAY
C    DATE                 04-16-90
C    REVISED              02/12/92 JJC - RENAMED EQMO0 TO SAEQMO0.
C                                        FOR CRAY CONVERSION.
C
C
C    CALL SAEQMO0(OH,ICC,AUTO3,IABORT,RA)
C    CALL SAEQMO1(OH,OTR,VEL,PASS,IABORT,RA,SA)
C    CALL SAEQMO2(OH,OTR,VEL,PASS,IABORT,RA,SA)
C    CALL SAEQMO3(OH,OTR,VEL,PASS,IABORT,RA,SA)
C
C
C    THIS IS A SPARC DEVELOPMENT PROGRAM
C
C
C======================================================================
C                LOCAL VARIABLES
C
CA    BN
CA    DF       = FREQUENCY INCREMENT
CA    DP       = FORWARD DIP
CA    DR       = REVERSE DIP
CA    DX       = OFFSET INCREMENT
CA    F3       = HIGH CUT CORNER
CA    F4       = HIGH CUT TAIL
CA    IABORT   = JOB ABORT FLAG
CA    IFLAG    = INPUT DATA CARD, DF16
CA    IPR      = PRINT UNIT
CA    ISHOT    = CDP INDEX
CA    ISKP     = TRACE SKIPPED FLAG
CA             =0 : PREVIOUS TRACE GOOD;
CA             >0 : PREVIOUS TRACE SKIPPED
CA    ITRL     = TRACE COUNTER WITHIN CDP
CA    JFLAG    = INPUT DATA CARD, DF17
CA    KBG      = FIRST TRACE COUNTER / BIN
CA    KBUGF    = DEBUG FLAG
CA    KICC     = MINIMUM FIRST LIVE VALUE / BIN
CA    KED      = LAST TRACE COUNTER / BIN
CA    KICD     = MAXIMUM FIRST LIVE VALUE / BIN
CA    KICE     = FIRST LIVE VALUE OF TRACE
CA    KLEN     = FFT LENGTH EXPONENT
CA    KLOC     = TRACE INDEX LOCATION
CA    KLON     = FFT LENGTH IN TIME
CA    KNX      = FFT LENGTH IN X
CA    KONT     = NUMBER OF POSSIBLE TRACES / BIN
CA    KUNT     = NUMBER OF TRACES / BIN
CA    LICD     = STATUS OF PREVIOUS TRACE
CA    LON      = NUMBER OF SAMPLES PER TRACE
CA    LSMXFD   = LINE CARD MAXIMUM FOLD
CA    MX       = BIN CENTER OFFSET
CA    MXFOLD   = MAXIMUM FOLD
CA    NTRC     = TRACE COUNTER WITHIN CDP
CA    NTX      = OUTPUT FOLD
CA    NX       = NUMBER OF PARTIAL STACK TRACES
CA    OH       = TRACE HEADER
CA    STK      = WORK ARRAY
CA    STL      = WORK ARRAY
CA    X        = BINNED NEW OFFSET
CA    X2       = OFFSET
CA    X3       = OFFSET SQUARE
CA    XFR      = FAR OFFSET
CA    XNR      = NEAR OFFSET
CA    XO       = BINNING OFFSET
CA    XOFF     = NORMALIZED OFFSET SQUARE
CA    XSCL     = OFFSET SCALING
CA    XX       = OUT FOR JFLAG=2
CA    Y        = OUTPUT TRACE AFTER DIP FILTERING
CA    YY       = OUT FOR JFLAG = 2
CA    Z        = WORK ARRAY
CA
C=======================================================================
C                  FORMAT OF OUTPUT PARAMETER RECORDS                   00770000
C                                                                       00780000
C                 ****** PROCESSING RANGES/PARMS ******                 00790000
C ===================================================================== 00800000
C                                                                       00810000
C WORD 1  WORD 2   WORD 3  WORD 4  WORD 5  WORD 6  WORD 7    WORD 8     00820000
C |_______|________|_______|_______|_______|_______|_________|_______|  00830000
C | EQMO  | PROCESS|  PTS  |  NOT  |  NOT  |# OF   |  PMODE  |  NOT  |  00840040
C |_______|_NUMBER_|_______|_USED__|_USED__|__PARMS|_________|_USED__|  00850000
C                                                                       00860000
C WORD 9  WORD 10  WORD 11 WORD 12 WORD 13 WORD 14 WORD 15   WORD 16    00870000
C |_______|________|_______|_______|_______|_______|_________|_______|  00880000
C | IBEG  | IEND   | IFLAG | JFLAG |  XNR  |  XFR  |  DX     |  BN   |  00890041
C |_______|________|_______|_______|_______|_______|_________|_______|  00900041
C                                                                       00910000
C WORD 17 WORD 18  WORD 19 WORD 20 WORD 21 WORD 22                      00920000
C |_______|________|_______|_______|_______|_______|                    00930000
C |  DP   |  DR    |  F3   |  F4   |  NOT  |  NOT  |                    00940041
C |_______|________|_______|_______|__USED_|__USED_|                    00950041
C
C --------------------------------------------------------------------
C
      SUBROUTINE SAEQMO0(OH,ICC,AUTO3,IABORT,RA)
C
C**************************************************************
C                                                             *
C SUBROUTINES AND FUNCTIONS CALLED FROM THIS ROUTINE          *
C                                                             *
C FORC      USRTHV    SAEQMOD   SCOPY     SAEQMOA   SAEQMOB   *
C ARMVE     SSCAL     ARSET     USSTHV                        *
C                                                             *
C**************************************************************
C
      IMPLICIT INTEGER (A-Z)
C
      REAL     OH(*), OTR(*), RA(*), SA(*), VEL(*)
C
      CHARACTER*1  MODE
      CHARACTER    DCTYP
C                                                                       01020320
C                REAL ARRAYS--LOCAL                                     01020330
C                                                                       01020340
      REAL         ATTR ( 96)                                           01020350
C                                                                       01020360
C                 INTEGER ARRAYS--LOCAL                                 01020370
C                                                                       01020380
      INTEGER      DENTRY   (104)                                       01020390
      INTEGER      DATTR    ( 96)                                       01020390
C
C
C     INTEGER  INH
C     INTEGER  OH
      INTEGER  PASS
      INTEGER  YES
      INTEGER  NO
      INTEGER  YES3
      INTEGER  NO3
      INTEGER  AUTO3
      INTEGER  ORTN
      INTEGER  CDPN
      INTEGER  CDPT
      INTEGER  TICD
      INTEGER  XDST
      INTEGER  NS
      INTEGER  SI
      INTEGER  SSP
      INTEGER  FN
C     INTEGER  DATA
      INTEGER  ULOCAL
      INTEGER  SLOCAL
C
      INTEGER LON, KSHOT, TRL, IABORT, ISR, LA, IPR,
     +        ICC, IBEG, IEND, LCTPSP, NSHO2, I, J, K, L, JSHT,
     +        LSHOT, MSHOT, NTRC, KPBUGF, KPMITF, ISHOT, IFIRST, NTR,
     +        LTRC, KDS, LD, KPPRNT, JSHOT, LSHT, IS, IND, NTX,
     +        KPNRSM, KPNUSM, THL, LCRL, LCPI, LCBGSP, LCENSP, LCMXFD,
     +        NSHHF, JERR, KBUGF, NSHO1,
     +        NSHOT, KOUNT, MXFOLD, NSHOTT
      INTEGER IN11, INLD, IND5, INX1, INX2, INX3, IND1, IND0, IND2,
     +        IND3, IND4, IND6, ISTK, JSTK,
     +        IKUN, IKBG, IKED, IKIC, IKON, IMX, IKLO, IXO,
     +              INXE, IKIE, KFLAG
      INTEGER NX, IFLAG, JFLAG, KLN, KNX, KLEN, KLON, ISKP
      REAL    XNR, XFR, XFR2, F3, F4, DP, DR, BN,
     +        CON, ALN2, FIBN
C
      REAL    FSR, DT, DX, XSCL, DF, TOLR, DW
C
      DATA    YES  /0/
      DATA    NO   /1/
      DATA    YES3 /2/
      DATA    NO3  /3/
C
C
C
C     COMMON  /P/  STATEMENTS GENERATED BY UTCGI4              6/17/91
      COMMON  /P/  STARTP (               2)           , M00000(    5)
      COMMON  /P/  LCBGSP
      COMMON  /P/  LCENSP                              , M00032(    3)
      COMMON  /P/  LCTPSP
      COMMON  /P/  LCRL                                , M00052
      COMMON  /P/  LCPI
      COMMON  /P/  LCGRPI
      REAL         LCGRPI
      COMMON  /P/  LCMXFD                              , M00068(   86)
      COMMON  /P/  KPNA
      COMMON  /P/  KPRNO                               , M00420(   13)
      COMMON  /P/  KPNRSM                              , M00476
      COMMON  /P/  KPNUSM                              , M00484(    9)
      COMMON  /P/  KPMITF
      COMMON  /P/  KPPRNT                              , M00528(    2)
      COMMON  /P/  KPBUGF                              , M00540(  226)
      COMMON  /P/  ENDP
C
      COMMON  /HEAD/ ORTN,CDPN,CDPT,TICD,XDST,NS,SI,SSP,FN
      COMMON  /USER/ SLOCAL(50), ULOCAL(100)
C
C                                                                       01020560
      EQUIVALENCE (DCTYP        ,DENTRY (03))                           01020570
      EQUIVALENCE (SPT          ,DENTRY (04))                           01020580
      EQUIVALENCE (EPT          ,DENTRY (05))                           01020590
      EQUIVALENCE (NOPAR        ,DENTRY (06))                           01020600
      EQUIVALENCE (PMODE        ,DENTRY (07))                           01020610
      EQUIVALENCE (SPLOCN       ,DENTRY (08))                           01020620
      EQUIVALENCE (DATTR(1)     ,DENTRY (09))                           01020630
C
      EQUIVALENCE (DATTR(1)     ,ATTR   (01))                           01020630
C                                                                       01020640
C
C
      EQUIVALENCE (BN     ,ULOCAL( 1))
      EQUIVALENCE (DF     ,ULOCAL( 2))
      EQUIVALENCE (DP     ,ULOCAL( 3))
      EQUIVALENCE (DR     ,ULOCAL( 4))
      EQUIVALENCE (DX     ,ULOCAL( 5))
      EQUIVALENCE (F3     ,ULOCAL( 6))
      EQUIVALENCE (F4     ,ULOCAL( 7))
      EQUIVALENCE (IBEG   ,ULOCAL( 8))
      EQUIVALENCE (IEND   ,ULOCAL( 9))
      EQUIVALENCE (IFIRST ,ULOCAL(10))
      EQUIVALENCE (IFLAG  ,ULOCAL(11))
      EQUIVALENCE (IKBG   ,ULOCAL(12))
      EQUIVALENCE (IKED   ,ULOCAL(13))
      EQUIVALENCE (IKIC   ,ULOCAL(14))
      EQUIVALENCE (IKIE   ,ULOCAL(15))
      EQUIVALENCE (IKLO   ,ULOCAL(16))
      EQUIVALENCE (IKON   ,ULOCAL(17))
      EQUIVALENCE (IKUN   ,ULOCAL(18))
      EQUIVALENCE (IMX    ,ULOCAL(19))
      EQUIVALENCE (IND    ,ULOCAL(20))
      EQUIVALENCE (IND1   ,ULOCAL(21))
      EQUIVALENCE (IND2   ,ULOCAL(22))
      EQUIVALENCE (IND3   ,ULOCAL(23))
      EQUIVALENCE (IND4   ,ULOCAL(24))
      EQUIVALENCE (IND5   ,ULOCAL(25))
      EQUIVALENCE (IND6   ,ULOCAL(26))
      EQUIVALENCE (INLD   ,ULOCAL(27))
      EQUIVALENCE (INXE   ,ULOCAL(28))
      EQUIVALENCE (INX1   ,ULOCAL(29))
      EQUIVALENCE (INX2   ,ULOCAL(30))
      EQUIVALENCE (INX3   ,ULOCAL(31))
      EQUIVALENCE (IPR    ,ULOCAL(32))
      EQUIVALENCE (ISHOT  ,ULOCAL(33))
      EQUIVALENCE (ISKP   ,ULOCAL(34))
      EQUIVALENCE (ISTK   ,ULOCAL(35))
      EQUIVALENCE (IXO    ,ULOCAL(36))
      EQUIVALENCE (JFLAG  ,ULOCAL(37))
      EQUIVALENCE (JSHOT  ,ULOCAL(38))
      EQUIVALENCE (JSHT   ,ULOCAL(39))
      EQUIVALENCE (JSTK   ,ULOCAL(40))
      EQUIVALENCE (KDS    ,ULOCAL(41))
      EQUIVALENCE (KFLAG  ,ULOCAL(42))
      EQUIVALENCE (KLEN   ,ULOCAL(43))
      EQUIVALENCE (KLN    ,ULOCAL(44))
      EQUIVALENCE (KLON   ,ULOCAL(45))
      EQUIVALENCE (KNX    ,ULOCAL(46))
      EQUIVALENCE (IN11   ,ULOCAL(47))
      EQUIVALENCE (KSHOT  ,ULOCAL(48))
      EQUIVALENCE (LA     ,ULOCAL(49))
      EQUIVALENCE (LD     ,ULOCAL(50))
      EQUIVALENCE (LON    ,ULOCAL(51))
      EQUIVALENCE (LSHOT  ,ULOCAL(52))
      EQUIVALENCE (LSHT   ,ULOCAL(53))
      EQUIVALENCE (LTRC   ,ULOCAL(54))
      EQUIVALENCE (MSHOT  ,ULOCAL(55))
      EQUIVALENCE (NSHHF  ,ULOCAL(56))
      EQUIVALENCE (NSHOT  ,ULOCAL(57))
      EQUIVALENCE (NSHO1  ,ULOCAL(58))
      EQUIVALENCE (NTR    ,ULOCAL(59))
      EQUIVALENCE (NTRC   ,ULOCAL(60))
      EQUIVALENCE (NTX    ,ULOCAL(61))
      EQUIVALENCE (NX     ,ULOCAL(62))
C     EQUIVALENCE (       ,ULOCAL(63))
      EQUIVALENCE (TRL    ,ULOCAL(64))
      EQUIVALENCE (XFR    ,ULOCAL(65))
      EQUIVALENCE (XFR2   ,ULOCAL(66))
      EQUIVALENCE (XNR    ,ULOCAL(67))
      EQUIVALENCE (XSCL   ,ULOCAL(68))
C
      DATA CON/1.E30/,KOUNT/0/,ALN2/1.442695041/
      DATA FIBN/0.381966012/
C
C      OPENS FILE FOR DIRECT ACCESS
C
      IPR = KPPRNT
      IABORT = NO
      ISR = SI / 1000
      FSR = ISR
C
C      AUTO3 = YES  ====> AUTOMATIC SP, DP, OR F BOUNDARY DETECTION
C      AUOT3 = NO   ====> NO BOUNDARY DETECTION
C
      AUTO3 = NO
C      AUTO3 = YES
C
C                READ SEISPARM FILE
C
       IDA = 1                                                          07725700
   10  CALL FORP (KPNA, KPRNO, IDA, 104, DENTRY, * 330  )               07725800
       IF(S1CPCH (DCTYP, 1, 'PTS', 1, 3) .NE. 0) GO TO 10               07725900
C                                                                       07726000
       IBEG     = DATTR( 1)                                             07726100
       IEND     = DATTR( 2)                                             07726200
       IFLAG    = DATTR( 3)                                             07726300
       JFLAG    = DATTR( 4)                                             07726400
       XNR      = ATTR ( 5)                                             07726500
       XFR      = ATTR ( 6)                                             07726600
       DX       = ATTR ( 7)                                             07726700
       BN       = ATTR ( 8)                                             07726800
       DP       = ATTR ( 9)                                             07726900
       DR       = ATTR (10)                                             07727000
       F3       = ATTR (11)                                             07726900
       F4       = ATTR (12)                                             07727000
C
C
      CALL S1MVCH(PMODE, 1, MODE, 1, 1)
      KFLAG = 0
      IF (IABS ( IFLAG )  .GT. 10) KFLAG = 10
C
      CALL USRTHV ( OH, 'THNS    ', LON )
      CALL USRTHV ( OH, 'THSI    ', IS )
      CALL USRTHV ( OH, 'THL     ', THL )
      MXFOLD = MAX0 ( LCTPSP, LCMXFD )
      LON = MAX0 ( LON, LCRL / LCPI )
      KBUGF = KPBUGF
C
      XFR2 = XFR * XFR
C
      NTX = 1
      NX = 2 * INT ( XFR2 / (XFR2 - (XFR - DX - DX )  ** 2 )  + 1 )
 100  CONTINUE
      IF (NX .GE. MXFOLD) THEN
         NX = NX / 2
         GO TO 100
      ENDIF
C
      KLN = ALOG ( FLOAT ( NX - 1 )  )  * ALN2 + 1.
      KNX = 2 ** KLN
C
      KLEN = ALOG ( FLOAT ( LON - 1 )  )  * ALN2 + 1.
      KLON = 2 ** KLEN
C
      DT = 0.000001 * IS
      DF = 0.5 / DT
      DW = 1. / (KLON * DT )
C
C
      TOLR = DX * 0.5
C
      TRL = LON + THL
C
      IF (NSHOTT .EQ. 0) NSHOTT = 1
      NSHOTT = (NSHOTT / 2 )  * 2 + 1
      IF (NSHOT .EQ. 0) NSHOT = 1
C     NSHOT=MIN0(NSHOT,7)
C     NSHOT=MAX0(NSHOT,3,NSHOTT)
      NSHHF = NSHOT / 2
      NSHOT = 2 * NSHHF + 1
      NSHO1 = NSHHF + 1
      NSHO2 = MIN0 ( NSHOT, NSHHF + 2 )
C ----------------------------------- IHDR, RA
      IN11 = 1
C ----------------------------------- TEMP
      IND5 = MXFOLD * TRL + 1
C ----------------------------------- X
      IND1 = TRL + IND5
C ----------------------------------- XX
      IND2 = IND1 + NX * LON
C ----------------------------------- YY
      IND6 = IND2 + KNX * LON
C ----------------------------------- Y
      IND3 = IND6 + KNX * LON
C ----------------------------------- Z
      IND4 = IND3 + KNX * KLON
C ----------------------------------- ILCD
      INLD = IND4 + KNX * KLON
C------------------------------------ X1
      INX1 = INLD + MXFOLD
C------------------------------------ KICE
      INXE = INX1 + MXFOLD
C------------------------------------ X2
      INX2 = INXE + MXFOLD
C------------------------------------ X3
      INX3 = INX2 + MXFOLD
C------------------------------------ STK
      ISTK = INX3 + MXFOLD
C ----------------------------------- STL
      JSTK = ISTK + KNX
C------------------------------------ KUNT
      IKUN = JSTK + KNX
C ----------------------------------- KBG
      IKBG = IKUN + KNX
C------------------------------------ KED
      IKED = IKBG + KNX
C ----------------------------------- KICD
      IKIC = IKED + KNX
C ----------------------------------- KICC
      IKIE = IKIC + KNX
C ----------------------------------- KONT
      IKON = IKIE + KNX
C------------------------------------ MX
      IMX = IKON + KNX
C ----------------------------------- KLOC
      IKLO = IMX + KNX
C ----------------------------------- XO
      IXO = IKLO + KNX
C -----------------------------------
      IND0 = IXO + KNX * 2
C
C     WRITE(IPR,109)IN11,IND5,IND1,IND2,IND6,IND3,INLD,INX1,INX2,INX3,
C    +              ISTK,JSTK,IKUN,IKBG,IKED,IKIC,IKON,IMX ,IKLO,IXO ,
C    +              IND0
C
      ICC = IND0 + KNX
C
      WRITE ( IPR, 9020 ) IBEG, IEND, XNR, XFR, DX, BN, DP, DR, F3, F4,
     1   DF, IFLAG
      WRITE ( IPR, 9025) JFLAG
C
      JFLAG = MOD ( JFLAG + 3, 4 )
      WRITE ( IPR, 9030 ) JFLAG, NX, NTX, KNX, MXFOLD, LON, KLON, DT,
     1   KBUGF, ICC
C
      IFLAG = MOD ( IFLAG, 10 )
      IF (KFLAG .NE. 0 .AND. (IFLAG .EQ. 1 .OR. IFLAG .EQ. 2 ) ) WRITE
     1    ( IPR, '(10X,A)' ) 'NO NORMALIZATION APPLIED!'
C
      XSCL = 0.0002 ** 2
C     SLOGE=XSCL*2.302585094
C
C----------------------- IFIRST=0 BEFORE FIRST SHOT
C----------------------- IFIRST=1 FOR TRACES WITHIN RANGE
C----------------------- IFIRST<0 FOR TRACES OF LAST SHOTS
C----------------------- IFIRST=0 BEYOND LAST SHOT
      IFIRST = 0
C----------------------- JSHT=0 BEFORE LAST TRACE OF LAST SHOT
C----------------------- JSHT=1 AFTER READING BEYOND LAST SHOT
C----------------------- JSHT=-1 AFTER PASSING THE LAST SHOT
      JSHT = 0
C
      KSHOT = 1
      NTRC = 0
      ISKP = 1
C
      RETURN
C
C              SAEQMO1 ENTRY STARTS HERE
C
C*******************************************************************
C*******************************************************************
C
      ENTRY SAEQMO1 ( OH, OTR, VEL, PASS, IABORT, RA, SA )
C
C*******************************************************************
C*******************************************************************
C
      IABORT = NO
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9040 ) PASS, IABORT, CDPN, CDPT,
     1   NTRC, NSHOT, KPNRSM, KPNUSM
C
C*******************************************************************
C*******************************************************************
C
      ENTRY SAEQMO2 ( OH, OTR, VEL, PASS, IABORT, RA, SA )
C
C*******************************************************************
C*******************************************************************
C
      IF (IFIRST .EQ. 0) PASS = NO
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9050 ) NTRC, PASS, MSHOT, KSHOT,
     1   JSHOT, KPMITF
C
      IF (KPMITF .EQ. 1) GO TO 120
C        KPMITF NORMALLY 1 (MEANING MORE INPUT)
      WRITE ( IPR, 9060 )
      PASS = NO
      RETURN
C
 120  CONTINUE
      IF (JSHT .NE. 0) RETURN
C
      CALL USRTHV ( OH, 'THTICD  ', LD )
      IF (LD .GT. 2) RETURN
C
      CALL USRTHV ( OH, 'THCDPN  ', ISHOT )
C
C     IF(ISHOT.LT.IBEG) RETURN
      IF ((ISHOT .LT. IBEG .OR. ISHOT .GT. IEND )  .AND. IFIRST .EQ. 0)
     1   RETURN
      IF ((ISHOT .LT. IBEG .OR. ISHOT .GT. IEND )  .AND. IFIRST .NE. 0)
     1   GO TO 160
      IF (IFIRST .EQ. 0) THEN
C
         JSHOT = ISHOT
         IFIRST = 1
         PASS = NO
C
         IF (KBUGF .GT. 2) WRITE ( IPR, 9070 )
         IF (KBUGF .GT. 2) WRITE ( IPR, 9080 ) NTRC, PASS, MSHOT, KSHOT
     1      , JSHOT
C
         CALL SAEQMOD ( NX, XNR, XFR, DX, IPR, KBUGF, KNX, DP, DR, BN,
     1      IFLAG, RA(IXO), RA(IMX), RA(IKON) )
C
      ENDIF
      IF (PASS .EQ. YES) RETURN
C
      PASS = NO
C
      IF (KBUGF .GE. 3) THEN
         CALL USRTHV ( OH, 'THORTN  ', NTR )
         CALL USRTHV ( OH, 'THXDST  ', KDS )
         WRITE ( IPR, 9090 ) ISHOT, LD, NTR, KDS
      ENDIF
C
 140  CONTINUE
      IF (ISHOT .NE. JSHOT) GO TO 160
C
      CALL USRTHV ( OH, 'THTICD  ', I )
      IF (I .NE. 1) THEN
C        IF(KBUGF.GT.0) THEN
         CALL USRTHV ( OH, 'THCDPT  ', NTR )
         WRITE ( IPR, * ) ' TRACE', NTR, '  WITHIN CDP', JSHOT,
     1      '  SKIPPED'
C        ENDIF
         ISKP = ISKP + 1
         RETURN
      ENDIF
C
      CALL SCOPY ( TRL, OH, 1, RA(IN11 + NTRC * TRL), 1 )
C
      NTRC = NTRC + 1
C
C     WRITE(IPR,*)' ENTR2 SAEQMOA ******'
      CALL SAEQMOA ( LON, OH, NX, KNX, KLON, ISHOT, NTRC, XNR, XFR,
     1   XSCL, KBUGF, IPR, LCMXFD, MXFOLD, ISKP, RA(IKUN), RA(IKBG), RA(
     2   IKED), RA(IKIC), RA(IXO), RA(INX1), RA(INX2), RA(INX3), RA(INLD
     3   ), RA(IND1), RA(INXE), RA(IKIE) )
C     WRITE(IPR,'(1X,12Z10)')(RA(IN11+I-1+(NTRC-1)*TRL),I=1,36)
C
      ISKP = 0
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9100 ) NTRC, LSHOT, KSHOT, PASS
      RETURN
C
 160  CONTINUE
C
      IF (NTRC .EQ. 0) THEN
         WRITE ( IPR, * ) 'NO LIVE TRACES FOUND FOR CDP =', JSHOT
         JSHOT = ISHOT
         GO TO 140
      ENDIF
C
      LTRC = NTRC
      JERR = NTRC
C
      IF (JERR .LE. 0) THEN
         KSHOT = KSHOT - 1
      ELSE
C
         IF (KBUGF .GT. 2) WRITE ( IPR, 9110 ) NTRC, PASS
C
C     CALL ARMVE(OH,RA(IND5),TRL)
         CALL SCOPY ( TRL, OH, 1, RA(IND5), 1 )
C
         IF (KBUGF .GE. 3) THEN
            CALL USRTHV ( OH, 'THORTN  ', NTR )
            WRITE ( IPR, 9120 ) ISHOT, NTR, PASS
         ENDIF
C
      ENDIF
      NTRC = 0
C
      IF (ISHOT .GE. IBEG .AND. ISHOT .LE. IEND) GO TO 180
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9130 )
C
      IFIRST = (-NSHHF )  - 1
      IFIRST = IFIRST - NSHHF
      IF (JERR .LE. 0) IFIRST = IFIRST + 1
C
      JSHT = 1
      PASS = NO3
      RETURN
C
 180  CONTINUE
C
      JSHOT = ISHOT
      KSHOT = KSHOT + 1
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9140 ) JSHOT, KSHOT, LSHOT, NTRC,
     1   PASS
C
      PASS = NO3
      RETURN
C
C*******************************************************************
C*******************************************************************
C
      ENTRY SAEQMO3 ( OH, OTR, VEL, PASS, IABORT, RA, SA )
C
C*******************************************************************
C*******************************************************************
C
      IF (JSHT .GE. 0) GO TO 200
      PASS = NO
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9150 ) JSHT, PASS, KPMITF
      RETURN
C
 200  CONTINUE
      IF (KPMITF .EQ. 0 .AND. JSHT .EQ. 0) JSHT = 1
C
      IF (JSHT .NE. 0 .AND. IFIRST .GT. 0) THEN
C
         LTRC = NTRC
C
         IF (KBUGF .GT. 2) WRITE ( IPR, 9160 ) NTRC, PASS
C
         JERR = NTRC
         IF (JERR .LE. 0) THEN
            IFIRST = -NSHHF
            KSHOT = KSHOT - 1
         ELSE
            IFIRST = -NSHO1
         ENDIF
C
         IFIRST = IFIRST - NSHHF
C
         NTRC = 0
C
      ENDIF
      IF (NTRC .NE. 0) GO TO 260
 220  CONTINUE
C
      IF (IFIRST .LT. 0) IFIRST = IFIRST + 1
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9170 ) NTRC, IFIRST, MSHOT, LTRC
C
      IF (LTRC .EQ. 0) GO TO 280
C
      IF (KSHOT .EQ. KOUNT) GO TO 240
C
C     WRITE(IPR,*)' ENTR3 SAEQMOB ******'
C     WRITE(IPR,'(1X,12Z10)')(RA(IN11+I-1             ),I=1,36)
      CALL SAEQMOB ( ISHOT, IFLAG, JFLAG, LON, MXFOLD, IPR, KBUGF,
     1   IABORT, XSCL, F3, F4, NX, KNX, KLN, KLON, KLEN, DF, TRL,
     2   DP, DR, NTX, RA(IKUN), RA(IKBG), RA(IKED), RA(IKIC), RA(IKON),
     3   RA(IMX), RA(IKLO), RA(INLD), RA(INX2), RA(ISTK), RA(JSTK), RA(
     4   IND1), RA(IND2), RA(IND6), RA(IND3), RA(IND4), RA(IN11 + THL),
     5   RA(INXE), RA(IKIE) )
C
      IF (IABORT .EQ. YES) GO TO 340
C
 240  CONTINUE
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9180 ) KSHOT, NSHOT, MSHOT, JSHOT,
     1   KOUNT
C
      PASS = YES3
C
 260  CONTINUE
C
      NTRC = NTRC + 1
C
      IF (NTRC .LE. NX) THEN
         IF (JFLAG .GT. 2) GO TO 260
C
C ----- JFLAG = 0,1,2
C
         NTR = NTRC
         CALL ARMVE ( RA(IKLO + NTR - 1), I, 1 )
         LD = 1
         IF (JFLAG .GT. 1) LD = 39
         CALL ARMVE ( RA(IMX + NTR - 1), KDS, 1 )
         IND = IND1
         L = NTR
         K = LON
      ELSE IF (NTRC .LE. NX+KNX) THEN
         IF (JFLAG .GT. 2) GO TO 260
         IF (JFLAG .EQ. 0) GO TO 280
C
C ----- JFLAG = 1,2
C
         NTR = NTRC - NX
         I = 1
         LD = 40
         KDS = MOD ( NTR - 1 + KNX / 2, KNX )  + 1
         IND = IND2
         L = KDS
         K = LON
      ELSE IF (NTRC .LE. NX+KNX*2) THEN
         IF (JFLAG .GT. 2) GO TO 260
         IF (JFLAG .EQ. 1) GO TO 280
C
C ----- JFLAG = 2
C
         NTR = NTRC - NX
         I = 1
         LD = 40
         KDS = MOD ( NTR - KNX - 1 + KNX / 2, KNX )  + 1
         IND = IND6
         L = KDS
         K = LON
      ELSE
         IF (NTRC .GT. (NX+KNX ) *2) GO TO 280
C
C ----- JFLAG = 3
C
         NTR = NTRC - NX - KNX * 2
         CALL ARMVE ( RA(IKLO + NTR - 1), I, 1 )
         LD = 1
         CALL ARMVE ( RA(IMX + NTR - 1), KDS, 1 )
         IND = IND3
         L = NTR
         K = KLON
C
C        NO NORMALIZATION ON PARTIAL STACKS
C
         LA = 0
         IF (KFLAG .NE. 0 .AND. (IFLAG .EQ. 1 .OR. IFLAG .EQ. 2 ) ) THEN
            CALL ARMVE ( RA(IKUN + NTR - 1), LA, 1 )
            CALL SSCAL ( LON, FLOAT ( LA ) , RA(IND + (L - 1 )  * K), 1
     1          )
         ENDIF
      ENDIF
C
      J = I
      IF (I .LE. 0) I = 1
      CALL SCOPY ( THL, RA(IN11 + (I - 1 )  * TRL), 1, OH, 1 )
      IF (J .EQ. 0) THEN
         CALL ARSET ( OTR, LON, 0. )
         IF (LD .NE. 1) THEN
            OTR(LON) = 1.E-30
         ELSE
            LD = 2
         ENDIF
      ELSE
         CALL SCOPY ( LON, RA(IND + (L - 1 )  * K), 1, OTR, 1 )
      ENDIF
C
      IF (KBUGF .GT. 2) WRITE ( IPR, '(A,9I9)' )
     1   'NTRC/NTR/LD/KDS/I/J/IND/L/K:', NTRC, NTR, LD, KDS, I, J, IND,
     2   L, K, LA
      IF (KBUGF .GT. 2) WRITE ( IPR, '(1X,13G10.4)' )  ( OTR(I), I = 1,
     1   K, 100 )
C
      CALL USSTHV ( OH, 'THORRN  ', NTR )
      CALL USSTHV ( OH, 'THORTN  ', NTR )
      CALL USSTHV ( OH, 'THTICD  ', LD )
      CALL USSTHV ( OH, 'THXDST  ', KDS )
      CALL USSTHV ( OH, 'THFLV   ', 1 )
C
C               SET PARTIAL-STACK FOLD
C
      IF (NTRC .GT. NX+KNX*2 .AND. (IFLAG .EQ. 1 .OR. IFLAG .EQ. 2 ) )
     1   CALL USSTHV ( OH, 'THNVST  ', LA )
C
      IF (KBUGF .LT. 3) RETURN
      CALL USRTHV ( OH, 'THCDPN  ', ISHOT )
      CALL USRTHV ( OH, 'THORTN  ', NTR )
      WRITE ( IPR, 9190 ) MSHOT, ISHOT, NTR, LSHT, NTRC, PASS
      RETURN
C
 280  CONTINUE
      NTRC = 0
      ISKP = 1
C
      IF (KBUGF .GT. 2) WRITE ( IPR, 9200 ) NTRC, KSHOT, MSHOT, ISHOT,
     1   IFIRST, PASS
C
      IF (IFIRST .LT. 0) GO TO 220
C
      PASS = NO
C     IF(KPMITF.EQ.0) RETURN
      IF (KPMITF .EQ. 0) GO TO 300
C
C     IF(IFIRST.EQ.0) PASS=YES
C
C     CALL ARMVE(RA(IND5),OH,TRL)
      CALL SCOPY ( TRL, RA(IND5), 1, OH, 1 )
C
      IF (JSHT .NE. 0) JSHT = -1
C
      IF (JSHT .LT. 0) GO TO 300
C
      CALL ARSET ( RA(INX1), MXFOLD, 0. )
C
      CALL SCOPY ( TRL, OH, 1, RA(IN11), 1 )
C
      CALL USRTHV ( OH, 'THTICD  ', I )
      IF (I .NE. 1) THEN
C        IF(KBUGF.GT.0) THEN
         CALL USRTHV ( OH, 'THCDPT  ', NTR )
         WRITE ( IPR, * ) ' TRACE', NTR, '  WITHIN CDP', JSHOT,
     1      '  SKIPPED'
C        ENDIF
         ISKP = ISKP + 1
         RETURN
      ENDIF
C
      NTRC = NTRC + 1
C
C     WRITE(IPR,*)' ENTR3 SAEQMOA ******'
      CALL SAEQMOA ( LON, OH, NX, KNX, KLON, ISHOT, NTRC, XNR, XFR,
     1   XSCL, KBUGF, IPR, LCMXFD, MXFOLD, ISKP, RA(IKUN), RA(IKBG), RA(
     2   IKED), RA(IKIC), RA(IXO), RA(INX1), RA(INX2), RA(INX3), RA(INLD
     3   ), RA(IND1), RA(INXE), RA(IKIE) )
C
      ISKP = 0
C
      IF (KBUGF .LT. 3) RETURN
      WRITE ( IPR, 9100 ) NTRC, LSHOT, KSHOT, PASS
      CALL USRTHV ( OH, 'THCDPN  ', ISHOT )
      CALL USRTHV ( OH, 'THTICD  ', LD )
      CALL USRTHV ( OH, 'THORTN  ', NTR )
      IF (NTR .EQ. 1) WRITE ( IPR, 9090 ) ISHOT, LD, NTR, JSHT
      WRITE ( IPR, 9210 ) JSHT, PASS, KPMITF
      RETURN
C
 300  CONTINUE
C
      RETURN
C
C                ****************
C                 ERROR MESSAGES
C                ****************
C
 320  CONTINUE
C
      WRITE ( IPR, 9220 )
      GO TO 340
C
 330  WRITE ( IPR, 9230)
      GO TO 340
C
 340  CONTINUE
      IABORT = YES
C
C                ****************
C                   FORMAT
C                ****************
C
 9000  FORMAT(6X,A1,3X,2I5,8F5.0,2I5)
C
 9010 FORMAT(1X,15I8)
C
 9020 FORMAT(/10X,'BEGINNING CDP NUMBER =',I18,51X,'VERSION  05-07-91'//
     +        10X,'ENDING CDP NUMBER =',I21//
     +        10X,'MINIMUM NEAR OFFSET =',F19.1//
     +        10X,'MAXIMUM FAR OFFSET =',F20.1//
     +        10X,'TRACE INTERVAL WITH GATHER =',F12.2//
     +        10X,'MINIMUM TRACES PER BIN =    ',F12.2//
     +        10X,'TIME DIP AT MAXIMUM FAR OFFSET =',F8.1//
     +        10X,'REVERSE TIME DIP AT FAR OFFSET =',F8.1//
     +        10X,'HIGH-CUT FREQUENCIES (HZ) = ',2F12.2,F38.2//
     +        10X,'FLAG (0,1,2,3) =            ',I12,
     +        22X,'FLAG = 0  (SELECT NEAREST TRACE PER BIN)'/
     +        72X,'     = 1  (PARTIAL STACK W/  NORMALIZATION)'/
     +        72X,'     = 11 (PARTIAL STACK W/O NORMALIZATION)'/
     +        72X,'     = 2  (MODE PARTIAL STACK W/  NORMALIZATION)'/
     +        72X,'     = 12 (MODE PARTIAL STACK W/O NORMALIZATION)'/
     +        72X,'     = 3  (MEDIAN)'                     // )
C
 9025 FORMAT( 10X,'FLAG2 (0,1,2,3) =           ',I12,
     +        22X,'FLAG2 = 0 (MULTIPLE-REMOVED OUTPUT ONLY)'   /
     +        72X,'      = 1 (PARTIAL STACK OUTPUT ONLY)'      /
     +        72X,'      = 2 (PARTIAL STACK & F-K OUTPUT ONLY)'/
     +        72X,'      = 3 (ALL THREE OUTPUTS)'              )
C
 9030 FORMAT(1H+,120X,I4//
     +        10X,'OUTPUT FOLD =               ',I12,I40,I10//
     +        10X,'MAXIMUM FOLD =',I26//
     +        10X,'NUMBER OF SAMPLES/TRACE =',I15,I50//
     +        10X,'TIME SAMPLING RATE =',F20.4,' (SEC)'//
     +        20X,'KPBUGF =',I22//
     +        20X,'ICC =',I25//)
C
 9040 FORMAT(' ***  ENTRY 1 *** ',  'PASS = ', I4, 4X, 'IABORT = ',
     +    I4, 4X, 'CDPN = ', I10, 4X, 'CDPT = ',5I10)
C
 9050 FORMAT(' ETR2 /NTRC/PASS/MSHOT/KSHOT/JSHOT/',6I7)
C
 9060 FORMAT(' NO MORE INPUT TRACES')
C
 9070 FORMAT(' FIRST GOOD TRACE')
C
 9080 FORMAT(1X,8I10,2E15.5)
C
 9090 FORMAT('+',70X,'OUT',4I10)
C
 9100 FORMAT(' NTRC=',I6,2I6,' PASS=',I5)
C
 9110 FORMAT(' NEW SHOT/NTRC/',I5,' PASS=',I5)
C
 9120 FORMAT(' SAVE/ISHOT/NTR/PASS/',3I7)
C
 9130 FORMAT(' > LAST SHOT')
C
 9140 FORMAT(' NEW SHOT/JSHOT/KSHOT/LSHOT/NTRC/',5I4,' PASS=',I5)
C
 9150 FORMAT(' END/JSHT/PASS/KPMITF/',3I7)
C
 9160 FORMAT(' LAST SHOT/NTRC/PASS/',2I6)
C
 9170 FORMAT(' ETR3/NTRC/IFIRST/MSHOT/LTRC/',4I5)
C
 9180 FORMAT(' CALC/KSHOT/NSHOT/MSHOT/JSHOT/KOUNT/',6I5)
C
 9190 FORMAT(' SPEW/MSHOT/ISHOT/NTR/LSHT/NTRC/',6I5,' PASS=',I5)
C
 9200 FORMAT(' SPEW/NTRC/KSHOT/MSHOT/ISHOT/IFIRST/',5I5,' PASS=',I5)
C
 9210 FORMAT(' SUCCESS/JSHT/PASS/',3I6)
C
 9220  FORMAT('0   NO DATA CARD FOUND')
C
 9230  FORMAT(' *** FORP READ ERROR *** ')
C
C
      RETURN
      END