CTITLESAVSFK0 - REFORMAT FOR VELOCITY DISPLAY
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
CA
CA   DESIGNER      BRUCE VERWEST
CA   AUTHOR        BRUCE VERWEST
CA   LANGUAGE      FORTRAN 77
CA   SYSTEM        IBM AND CRAY
CA   WRITTEN       APRIL 8,1987
C    REVISED       SEPT 1987    WRF   READ PARAMETERS FROM SEISPARM FILE
C    REVISED       04-14-88     WRF   CHANGE VFSK0,VFSK1,VFSK2,VFSK3
C                                     TO SAVSFK0,SAVSFK1,SAVSFK2,AND
C                                     SAVSFK3
C    REVISED       05-24-89     RDK   ADD IN SLOP FACTOR TO WORKFILE
C                                     ALLOCATION BECAUSE OF WEIRD
C                                     DISK REFERENCING LOGIC
C    REVISED       03-26-90     LWC   ADD PARAMETER TO FOISSD CALL.
CA
CA
CA    CALL SAVSFK0, SAVSFK1, SAVSFK2 AND SAVSFK3 FROM SDVSFK DRIVER
CA
CA
CA    THIS ROUTINE SELECTS AND SORTS DEPTH POINT VELOCITY GATHERS
CA    FROM MPFK INTO CONSTANT VELOCITY PANEL DISPLAYS WITH VELOCITY
CA    ANNOTATION.
CA
C     EJECT
C =====================================================================
C
C     PROCESS VSFK --  GENERATE CONSTANT VELOCITY DISPLAYS FOR MPFK
C     DATA CARD (1) -- DEFINE CDP RANGE AND PROCESSING PARAMETERS
C
C     NO. OF CARDS:    REQUIRED = 1   ALLOWED = 1
C
C                                                            REQ OR OPT
C  DF  COLS  DEFINITION                                      OR DEFAULT
C  --  ----- ----------                                      -----------
C   1   1- 4 'VSFK'                                          :   REQ   :
C   2    - 5 PROCESS NUMBER                                  :    0    :
C   3    - 6 NOT USED                                        :         :
C   4    - 7 PROCESSING MODE                                 :    D    :
C            'D' = DEPTH POINT                               :         :
C   5   8-10 BLANK                                           :         :
C   6  11-15 BEGINNING DEPTH POINT                           :   REQ   :
C   7  16-20 ENDING DEPTH POINT                              :   DF6   :
C   8  21-25 NUMBER OF CDPS IN A GROUP                       :    1    :
C   9  26-30 NUMBER OF CDPS TO INCREMENT FOR START OF GROUP  :    1    :
C                                                            :_________:
C
C
C  DF  NOTES
C  --  -----
C
C   4  PROCESSING IS RESTRICTED TO THE DEPTH POINT MODE.  THE INPUT
C      IS DEPTH POINT VELOCITY GATHERS FROM MPFK.
C
C
C =====================================================================
C      EJECT
C =====================================================================
C
C     PROCESS VSFK --  GENERATE CONSTANT VELOCITY DISPLAYS FOR MPFK
C     DATA CARD (2) -- DEFINE CDP RANGE FOR VELF VELOCITY IDS
C
C     NO. OF CARDS:    REQUIRED = 1   ALLOWED = 600
C
C                                                            REQ OR OPT
C  DF  COLS  DEFINITION                                      OR DEFAULT
C  --  ----- ----------                                      -----------
C   1   1- 4 'VSFK'                                          :   REQ   :
C   2    - 5 PROCESS NUMBER                                  :    0    :
C   3    - 6 NOT USED                                        :         :
C   4    - 7 NOT USED                                        :         :
C   5   8-10 'VEL'                                           :         :
C   6  11-15 STARTING DEPTH POINT                            :   REQ   :
C   7  16-20 ENDING DEPTH POINT                              :   DF6   :
C   8  21-25 VELF VELOCITY ID                                :   REQ   :
C                                                            -----------
C
C =====================================================================
C     EJECT
C
C
      SUBROUTINE SAVSFK0(OH,ICC,AUTO3,IABORT,RA)
      DIMENSION OH(1), OTR(1), RA(1),SA(1),VEL(1)
      DIMENSION INTR(104)
C     EXTERNAL ARRAY
C
C     COMMON  /P/  STATEMENTS GENERATED BY UTCGI4             12/13/83
      COMMON  /P/  STARTP   (   2)
      COMMON  /P/  LCNAME
      COMMON  /P/  LC5
      COMMON  /P/  LCINT
      COMMON  /P/  LCTYP
      COMMON  /P/  LC10
      COMMON  /P/  LCBGSP
      COMMON  /P/  LCENSP                              , M00032(    2)
      COMMON  /P/  LCNSP
      COMMON  /P/  LCTPSP
      COMMON  /P/  LCRL
      COMMON  /P/  LCSI
      COMMON  /P/  LCPI                                , M00060
      COMMON  /P/  LCMXFD                              , M00068(   13)
      COMMON  /P/  ACLNAM (               5)           , M00124(   68)
      COMMON  /P/  KPNA
      COMMON  /P/  KPRNO                               , M00420
      COMMON  /P/  KPA
      COMMON  /P/  KPDBGS
      COMMON  /P/  KPDBGA
      COMMON  /P/  KPDBGN
      COMMON  /P/  KPWRKS
      COMMON  /P/  KPWRKD
      COMMON  /P/  KPWKS2
      COMMON  /P/  KPWKD2
      COMMON  /P/  KPWKS3
      COMMON  /P/  KPWKD3                              , M00464
      COMMON  /P/  KPIRSM
      COMMON  /P/  KPNRSM
      COMMON  /P/  KPIUSM
      COMMON  /P/  KPNUSM
      COMMON  /P/  KPTIME
      COMMON  /P/  KPRTF
      COMMON  /P/  KPDRTF
      COMMON  /P/  KPMOTF
      COMMON  /P/  KPNBR
      COMMON  /P/  KPIBN
      COMMON  /P/  KPITSV
      COMMON  /P/  KPTAMF
      COMMON  /P/  KPLOTF
      COMMON  /P/  KPMITF
      COMMON  /P/  KPPRNT                              , M00528(    2)
      COMMON  /P/  KPBUGF                              , M00540(  226)
      COMMON  /P/  ENDP
C
      INTEGER  INH
      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  SAMPR
      INTEGER  SI
      INTEGER  SSP
      INTEGER  FN
      INTEGER  THL
      INTEGER  ULOCAL
      INTEGER  SLOCAL
      INTEGER  S1CVBN
      INTEGER  S1CPCH
      INTEGER  CHECK
C
      COMMON  /HEAD/ ORTN,CDPN,CDPT,TICD,XDST,NS,SI,SSP,FN,THL
      COMMON  /USER/ SLOCAL(50), ULOCAL(100)
C
C
      INTEGER       DATTR   ( 96)
      INTEGER       DENTRY  (104)
      INTEGER       DAP
      INTEGER       PMODE
      INTEGER       PTS
      INTEGER       DCTYP
C
C     DENTRY IS AN ARRAY TO HOLD A PARAMETER RECORD.  THE DEFINITIONS
C     OF THE FIRST EIGHT WORDS ARE FIXED.  THE REMAINING WORDS ARE
C     FOR VARIABLE PARAMETERS AND ARE USUALLY ADDRESSED USING "DATTR".
C     THE MAXIMUM LENGTH OF DENTRY IS 104 BECAUSE OF THE I/O ROUTINES.
C
      EQUIVALENCE    (DCTYP     , DENTRY (03))
      EQUIVALENCE    (SPT       , DENTRY (04))
      EQUIVALENCE    (SPE       , DENTRY (05))
      EQUIVALENCE    (NOPAR     , DENTRY (06))
      EQUIVALENCE    (PMODE     , DENTRY (07))
      EQUIVALENCE    (SPLOCN    , DENTRY (08))
      EQUIVALENCE    (DATTR(1)  , DENTRY (09))
C
C
      EQUIVALENCE (ISPT   ,ULOCAL( 1))
      EQUIVALENCE (IEPT   ,ULOCAL( 2))
C     EQUIVALENCE (ISPT   ,ULOCAL( 3))
C
      DIMENSION ISHOT(24)
      CHARACTER*8  NAME
C
      DATA     YES    /0/
      DATA     NO     /1/
      DATA     YES3   /2/
      DATA     NO3    /3/
      DATA     NAME        /'DEPTH   '/
C
      DATA     PTS    / 'PTS ' /
C
       IPR = KPPRNT
       IABORT = NO
C
C      AUTO3 = YES  ====> AUTOMATIC SP, DP, OR F BOUNDARY DETECTION
C      AUTO3 = NO   ====> NO BOUNDARY DETECTION
C
       AUTO3 = YES
C      AUTO3 = NO
C
C
C                READ INPUT CARDS
C
C     READ PARAMETER SELECTION FROM SEISPARM FILE CREATED IN PREP STEP
C
      DAP = 1
C
 100  CALL FORP (KPNA, KPRNO, DAP, 104, DENTRY, *998)
      IF (DCTYP .NE. PTS) GO TO 100
C
C     OBTAIN VARIABLES FROM ATTRIBUTE ARRAY DATTR
C
C#######################################################################
C
C     READ THE STARTING DP NUMBER FOR THIS PROCESSING RANGE
C
      ISPT = DATTR (1)
C
C     READ THE ENDING DP NUMBER FOR THIS PROCESSING RANGE
C
      IEPT = DATTR (2)
C
C-----------------------------------------------------------------------
C
C     READ THE NUMBER OF DEPTH POINTS TO USE AS A GROUP. THE DEFAULT
C     VALUE IS UNITY
C
C-----------------------------------------------------------------------
C
      NCDP = DATTR (3)
C
C-----------------------------------------------------------------------
C
C     OBTAIN THE NUMBER OF DEPTH POINTS TO INCREMENT FOR START OF
C     GROUP. THE DEFAULT VALUE IS UNITY
C
C-----------------------------------------------------------------------
C
      ISKIP = DATTR (4)
C
C-----------------------------------------------------------------------
C
C#######################################################################
C
       SAMPR = SI/1000
       DT=FLOAT(SI)*1.E-6
       NSAMP = NS
C
       NP = 0
       NPT = 0
      CALL ARSET(ISHOT, 24, 0)
C
       IV1 = 1
       IV2 = IV1 + NS
       ICC = IV2 + NS
C
      KNRA=(ICC+1023)*4/1024
      WRITE(IPR,5000) KNRA
 5000 FORMAT(/,1X,'MEMORY NEEDED FOR RESERVE AREA, K-BYTES  ',I10)
C
C
       WRITE (IPR,9020) NCDP,NAME,ISKIP,ISPT,IEPT
       WRITE (IPR,9080) NAME
C
C
       NRECS = LCMXFD*NCDP+10
C
       CALL UPAWRK(NRECS,NS*4,'A',KPWRKS,KPWRKD,DDNAME,IER,IERN)
       CALL UPAWRK(NRECS,THL*4,'B',KPWKS2,KPWKD2,DDNAME,IER,IERN)
C
C      IWFLAG = 0    FIRST TIME THROUGH
C      IWFLAG = 1    FIRST CDP IN GROUP
C      IWFLAG = 2    MIDDLE CDP'S IN GROUP
C      IWFLAG = 3    LAST CDP IN GROUP
C      IWFLAG = 4    CDP NOT IN ANY GROUP
C      IWFLAG = 5    CLOSE DISK
C      IWFLAG = 6    DISK CLOSED - NOP
C
       IWFLAG = 0
C
       RETURN
C
C
C
C
C              SAVSFK1 ENTRY STARTS HERE
C*******************************************************************
C*******************************************************************
C
       ENTRY SAVSFK1(OH,OTR,VEL,PASS,IABORT,RA,SA)
C
C*******************************************************************
C*******************************************************************
C
C   OPEN DISK AND INITIALIZE
C
CBJV
C     III = 1
C     WRITE (IPR,8001) III,CDPN,CDPT,IWFLAG
C8001 FORMAT(' *** VSFK',I2,'  CDPN,CDPT,IWFLAG =',3I5)
C
      IF(IWFLAG.EQ.0) THEN
          IWFLAG = 4
          CALL ARSET(RA(1),NS,0.0)
C
          CALL FOISSD(KPWRKS,NS*4, 0)
          ISEQDA = 1
          DO 161 IX=1,LCMXFD*NCDP+10
  161     CALL FOWSSD(KPWRKS,ISEQDA,RA(1))
          CALL FOCSD(KPWRKS)
          CALL FOIDSD(KPWRKD,NS*4)
C
          CALL FOISSD(KPWKS2,THL*4, 0)
          ISEQDA = 1
          DO 162 IX=1,LCMXFD*NCDP+10
  162     CALL FOWSSD(KPWKS2,ISEQDA,RA(1))
          CALL FOCSD(KPWKS2)
          CALL FOIDSD(KPWKD2,THL*4)
C
          IFNORM = YES
          AC = 0.0
          AMX = 0.0
          IFVEL = YES
C
      ENDIF
C
C   DECIDE WHICH IWFLAG APPLIES
C
      IF (CDPN .GE. ISPT .AND. CDPN .LE. IEPT) THEN
          KK = MOD(CDPN-ISPT,ISKIP) + 1
          IF (KK .EQ. 1) THEN
              IWFLAG = 1
          ELSE IF(KK .GT. 1 .AND. KK .LT. NCDP) THEN
              IF (IWFLAG .EQ. 4) THEN
                  IWFLAG = 1
              ELSE
                  IWFLAG = 2
              ENDIF
          ELSE IF (KK .EQ. NCDP) THEN
              IWFLAG = 3
          ELSE
              IWFLAG = 4
          ENDIF
      ENDIF
C
C NV = # VELOCITIES PER CDP
C NIN = # CDPS STORED
C IOUT = # CDPS OUT
C IVOUT = # VELOCITIES OUT
C
      IF (IWFLAG .EQ. 1) THEN
          NV = 1
          NIN = 1
          IOUT = 0
          IVOUT = 1
          CALL ARMVE(VEL, RA(IV1), NS)
          CALL ARMVE(VEL, RA(IV2), NS)
          IF (VEL(1) .LE. 0.0) IFVEL = NO
      ENDIF
      IF (IWFLAG .EQ. 2 .OR. IWFLAG .EQ. 3) THEN
          NIN = NIN + 1
          CALL ARMVE(VEL, RA(IV2), NS)
          IF (VEL(1) .LE. 0.0) IFVEL = NO
          IF (CDPN .EQ. IEPT) THEN
              IWFLAG = 3
          ENDIF
      ENDIF
C
C
C*******************************************************************
C*******************************************************************
C
      ENTRY SAVSFK2(OH,OTR,VEL,PASS,IABORT,RA,SA)
C
C*******************************************************************
C*******************************************************************
C
C
CBJV
C     III = 2
C     WRITE (IPR,8001) III,CDPN,CDPT,IWFLAG
C
      PASS = NO
      IF (IWFLAG .GE. 4) THEN
          RETURN
      ENDIF
      IF (IFNORM .EQ. YES) THEN
          AA = 0.0
          DO 210 I=1,NS
  210     AA = AMAX1(AA,ABS(OTR(I)))
          AC = AC+1.0
          AMX = AMX+AA
C         DO 210 I=1,NS
C         AC = AC+1.0
C 210     AMX = AMX+ABS(OTR(I))
      ENDIF
      NV = MAX0(NV,CDPT)
      ISEQDA = (CDPT-1)*NCDP + KK
      CALL FOWDSD(KPWKD2, ISEQDA, OH)
      CALL FOWDSD(KPWRKD, ISEQDA,OTR)
C
      IF (KPMITF .EQ. 0) IWFLAG = 3
C
      RETURN
C*******************************************************************
C*******************************************************************
C
      ENTRY SAVSFK3(OH,OTR,VEL,PASS,IABORT,RA,SA)
C
C*******************************************************************
C*******************************************************************
C
C
CBJV
C     III = 3
C     WRITE (IPR,8001) III,CDPN,CDPT,IWFLAG
C
      IF (IWFLAG .LE. 2) THEN
          PASS = NO
          GO TO 800
      ELSE IF (IWFLAG .EQ. 3) THEN
          PASS = YES3
          GO TO 500
      ELSE IF (IWFLAG .EQ. 4) THEN
          PASS = NO
          GO TO 800
      ELSE IF (IWFLAG .EQ. 5) THEN
          PASS = NO
          GO TO 850
      ELSE
          RETURN
      ENDIF
C
C OUTPUT DISPLAY
C
  500 CONTINUE
      NOUT = NIN
      IF (IFVEL .EQ. YES) NOUT = NIN+2
      IOUT = IOUT+1
      IF (IOUT .GT. NOUT) THEN
          IOUT = 1
          IVOUT = IVOUT+1
      ENDIF
      IF (IOUT .EQ. NOUT .AND. IVOUT .EQ. NV) PASS = YES
CBJV
C     WRITE (IPR,8002) NV,NIN,NOUT,IOUT,IVOUT,PASS
C8002 FORMAT (10X,'NV,NIN,NOUT,IOUT,IVOUT,PASS =',6I5)
C
      IF (IFVEL .EQ. NO) THEN
          GO TO 510
      ELSE
          IF (IOUT .EQ. 1 .OR. IOUT .EQ. NOUT) THEN
              GO TO 520
          ELSE
              GO TO 510
          ENDIF
      ENDIF
C
C OUTPUT TRACES
C
  510 CONTINUE
      ISEQDA = (IVOUT-1)*NCDP + IOUT
      IF (IFVEL .EQ. YES) ISEQDA = (IVOUT-1)*NCDP + IOUT -1
      CALL FORDSD(KPWKD2,ISEQDA, OH)
      CALL USRTHV(OH, 'THCDPT  ', JJ)
      CALL USSTHV(OH, 'THORTN  ', JJ)
      CALL FORDSD(KPWRKD,ISEQDA,OTR)
      GO TO 800
C
C OUTPUT VELOCITY
C
  520 CONTINUE
C
C TICK MARK IS SET TO AVERAGE PEAK VALUE OF TRACES IN FIRST GROUP
C
      IF (IFNORM .EQ. YES) THEN
C         AA = AMX
          AMX = AMX/AC
          EPS = -AMX/1000.
          IFNORM = NO
C         WRITE (IPR,8005) AA,AC,AMX
C8005     FORMAT ('   AA,AC,AMX = ',3E15.6)
      ENDIF
      IVV = IV1
      II = 1
      IF (IOUT .GT. 1) THEN
          IVV = IV2
          II = NIN
      ENDIF
      ISEQDA = (IVOUT-1)*NCDP + II
      CALL FORDSD(KPWKD2,ISEQDA, OH)
      CALL USRTHV(OH, 'THCDPT  ', JJ)
      CALL USSTHV(OH, 'THORTN  ', JJ)
      CALL ARSET(OTR, NS, EPS)
C     CALL ARSET(OTR, NS, 0.0)
      CALL USRTHV(OH, 'THXDST  ', IVEL)
C
      VELX = IVEL
      X1 = RA(IVV)
      D1 = VELX - X1
C     IF (D1 .EQ. 0.0) OTR(1) = AMX
C
      DO 540 I=2,NS
      X2 = RA(IVV+I-1)
      D2 = VELX - X2
      DD = D1*D2
C     IF (D2 .EQ. 0.0) OTR(I) = AMX
      IF (DD .LE. 0.0) THEN
          OTR(I) = AMX
          OTR(I-1) = -AMX
      ENDIF
      X1 = X2
      D1 = D2
  540 CONTINUE
C
C
C  TAKE CARE OF TRACE COUNTING
C
  800 CONTINUE
C
      IF (PASS .NE. YES3) THEN
          IF (IWFLAG .LT. 4) THEN
              NP = NP+1
              NPT = NPT + 1
              ISHOT(NP) = CDPN
              IF (PASS .EQ. YES) IWFLAG = 4
          ENDIF
          IF (NP .EQ. 24 .OR. KPMITF .EQ. 0) THEN
              WRITE (IPR,9090) NPT,(ISHOT(J),J=1,NP)
              NP = 0
              CALL ARSET(ISHOT, 24, 0)
          ENDIF
      ENDIF
C
  850 CONTINUE
C
      IF (PASS .NE. YES3) THEN
          IF ( KPMITF .EQ. 0 .AND. IWFLAG.NE.6) THEN
          CALL FOCDD(KPWRKD)
          CALL FOCDD(KPWKD2)
          IWFLAG=6
          ENDIF
      ENDIF
C
C   DEBUG PRINT
C
  900 CONTINUE
C     IF (KPBUGF .GT. 0) THEN
C         CALL USDTH(OH,IPR)
C         IF (NTO .EQ. 1) WRITE (IPR, 9400) (INTR(J),J=1,104)
C         IF (NTO .GT. 1) WRITE (IPR, 9410) (OTR(J),J=1,NS)
C9400     FORMAT (1X,(1X,10I10))
C9410     FORMAT (1X,(1X,10E10.4))
C     ENDIF
      RETURN
C
C
C                 ********************
C                 ********************
C                 ERROR MESSAGES
C                 ********************
C                 ********************
C
 998   IABORT = YES
       WRITE(IPR,9998)
       RETURN
C
C9999  IABORT = YES
C      WRITE(IPR,9130)
C      RETURN
C
C   WRITE FORMATS
C
 9000  FORMAT(6X,A1,3X,12I5)
C
 9020 FORMAT (' DISPLAY ',I5,1X,
     *       A5,' POINTS EVERY ',I5,' FROM ',I5,' TO ',I5,/)
C
 9080 FORMAT (/,' COUNT ',A5,' POINTS PROCESSED',/)
C
 9090 FORMAT (1X,I5,4(1X,6I5))
C
 9100 FORMAT (6X,4(1X,6I5))
C
 9130  FORMAT('0   NO DATA CARD FOUND')
C
 9210 FORMAT (1X,10E12.4)
C
 9998 FORMAT ('0*** FORP ERROR ON SEISPARM FILE ***')
C
       END