CATITLESPVADM - PRESTACK DEPTH MIGRATION AND FOCUSING ANALYSIS
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
C
CA     DESIGNER      JAMES C. SUN
CA     AUTHOR        JAMES C. SUN
CA     LANGUAGE      CRAY FORTRAN
CA     SYSTEM        IBM AND CRAY
CA     WRITTEN       03/26/87
C      REVISED       09/25/87 JCS   PAD ZERO TRACES FOR END-ON CABLE
C      REVISED       02/08/88 JCS   USE PHASE SHIFT FOR CONSTANT
C                                   VELOCITY WATER LAYER
C      REVISED       02/15/88 JCS   ADD VELOCITY MODEL QC PLOTS
C      REVISED       02/23/88 JCS   MODIFY VGRID SUBROUTINE;
C                                   EXPAND VELOCITY MODEL RANGE
C      REVISED       02/15/90 JJC - MODIFIED TO MEET EDP SPARC STANDARDS
C      REVISED       02/20/90 JJC - RENAMED VADMPP TO SPVADMA.
C      REVISED       06/18/90 JCS   ADDED 'DEN' CARD THAT ALLOWS:
C                                   1) DECIMATING THE RECEIVERS
C                                   2) OUTPUTING 2 TRACES PER SHOT
C      REVISED       11/07/90 CLJ   ALLOW PREP TO RUN ON THE IBM
C      REVISED       02/13/91 CLJ - CORRECTED ERROR IN NINT(LOCSAV)
C                                   CALCULATION FOR SPLIT SPREAD CASE
C                                   AS REQUESTED BY JAMES SUN.
C      REVISED       02/16/91 JCS   CORRECTED ERROR FOR SPLIT SPREAD CASE
C      REVISED       07/26/91 JCS   CORRECTED NZ AND CHECK FOR NZ=<NS   E
C      REVISED       12/05/91 JCS   CORRECTED ERROR FOR NO-FOCUSING-    E
C                                   ANALYSIS SITUATION
C      REVISED       07/30/92 JCS   ADDED 85 DEGREE ACCURACY OPTION     E
CA
CA
CA    CALL SPVADM (NO PARAMETERS)
CA
CA
CA    THIS PREPARATION ROUTINE SCRUTINIZES USER INPUT DATA CARDS
CA    FOR POSSIBLE ERRORS.  IF NO ERRORS ARE FOUND, THE PARAMETERS
CA    LISTED ON THE INPUT CARDS ARE USED TO DEVELOP PROCESSING
CA    PARAMETERS FOR USE BY THIS PREPARATION ROUTINE'S
CA    CORRESPONDING PROCESSOR.  THESE PARAMETERS ARE STORED ON
CA    DISK FOR ACCESS AT PROCESSING TIME.
CA
CA
C     EJECT
C
C     LOCAL ARRAYS  (INTERNAL TO SUBROUTINE).
C
C     CARD          = SPACE TO HOLD 80-CHAR. CARD INPUT DATA       C80
C     DATTR  (  96) = ARRAY FOR ATTRIBUTES OF DATA                  I4
C     DENTRY ( 104) = ARRAY FOR STORAGE OF LOCAL PARAMETERS         I4
C
C     LOCAL VARIABLES AND CONSTANTS  (INTERNAL TO SUBROUTINE).
C
C     DZ     = OUTPUT DEPTH STEP SIZE                               I4
C     ISBEG  = BEGINNING SHOT POINT                                 I4
C     ISEND  = ENDING    SHOT POINT                                 I4
C     IDXSS  = SHOT INTERVAL * 100                                  I4
C     IFLO   = LOW  CUT FREQUENCY                                   I4
C     IFHI   = HIGH CUT FREQUENCY                                   I4
C     IZMAX  = MAXIMUM DEPTH TO MIGRATE                             I4
C     IGBEG  = BEGINNING RECEIVER NUMBER                            I4
C     IGEND  = ENDING    RECEIVER NUMBER                            I4
C     MG     = TOTAL NUMBER OF RECEIVERS FOR A SHOT                 I4
C     IDXGG  = GROUP INTERVAL * 100                                 I4
C     LOCSHT = LOCATION OF SHOT IN A CABLE RELATIVE TO RECEIVER NO. I4
C     NG     = NUMBER OF RECEIVERS INCLUDING THE PADDING.           I4
C
C=======================================================================
CU    PROCESS VADM -- PRESTACK DEPTH MIGRATION AND FOCUSING ANALYSIS
CU
CU    DATA CARD (1) -- PROCESSING PARAMETERS
CU
CU    NO. OF CARDS:    REQUIRED = 1         ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |   0     |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 PROCESSING MODE                                 |  REQ    |
CU           'S' = SHOTPOINT                                 |         |
CU  5   8-10 BLANK                                           |         |
CU  6  11-15 STARTING SHOTPOINT                              |  REQ    |
CU  7  16-20 ENDING   SHOTPOINT                              |  REQ    |
CU  8  21-25 SHOTPOINT NO. INCREMENT (+,-)                   |   +1    |
CU  9  26-30 SHOTPOINT ADVANCE (% G. I.)                     |  100    |
CU 10  31-35 LOWEST FREQUENCY TO MIGRATE (HZ)                |  REQ    |
CU 11  36-40 HIGHEST FREQUENCY TO MIGRATE (HZ)               |  REQ    |
CU 12  41-45 Z (DEPTH) STEP SIZE (FT)                        |   20    |
CU 13  46-50 MAXIMUM DEPTH TO MIGRATE (FT)                   |  REQ    |
CU 14  51-55 ESTIMATED MAXIMUM TRUE DIP (DEGREES)            |NOTE DF14|
CU 15  56-60 VELOCITY MODEL SMOOTHING WINDOW LENGTH          |NOTE DF15|
CU 16  61-65 NUMERIC ID. -- REFERENCE TO CARD(2)             |  REQ    |
CU 17  66-70 SHALLOWEST WATER BOTTOM DEPTH                   |   0     |
CU 18  71-75 NUMBER OF DEPTH-STEP INCREMENT FOR DIFFRACTION  |NOTE DF18|
CU 19  76-80 FOR PROGRAMMER USE                              |         |
CU                                                           -----------
CU
CU DF  NOTES
CU --  -----
CU
CU  8  THIS NUMBER CAN BE EITHER POSITIVE OR NEGATIVE.
CU
CU  9  THIS NUMBER HAS TO BE INTEGER MULTIPLIER OF 100.
CU
CU 14  USE NEGATIVE VALUE FOR HIGHER ACCURACY.  THE CPU IS TWICE THE
CU      REGULAR CASE AND THE ACCURACY IS 85 DEGRE.
CU
CU 15  NUMBER OF VERTICAL DEPTH STEPS AND HORIZONTAL TRACES USED
CU     FOR SMOOTHING.  DEFAULT IS NO SMOOTHING.
CU
CU 18  DEFAULT IS 2; THE RANGE OF ALLOWED VALUE IS BETWEEN 1 AND 4.
CU
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (2) -- CABLE LAYOUT DEFINITION
CU
CU    NO. OF CARDS:    REQUIRED = 1         ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |   0     |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'CLD'                                           |  REQ    |
CU  6  11-15 NUMERIC ID. (CRAD(1) DF16)                      |  REQ    |
CU  7  16-20 STARTING TRACE NO. FOR THIS CABLE SEGMENT       |  REQ    |
CU  8  21-25 % G. I. BETWEEN EACH TRACE                      |  REQ    |
CU  9  26-30 ENDING TRACE NO.. FOR THIS CABLE SEGMENT        |  REQ    |
CU           (THIS BECOMES THE STARTING TRACE NO. FOR THE    |         |
CU            NEXT CABLE SEGMENT)                            |         |
CU 10  31-35 REPEAT PAIRS OF % G.I. AND TRACE NO. UNTIL ALL  |  REQ    |
CU           TRACES AND SHOTPOINT ARE DEFINED                |         |
CU           (THE SHOTPOINT IS DEFINED BY A 'X' IN PLACE     |         |
CU            OF TRACE NO.)                                  |         |
CU                                                           -----------
CU DF  NOTES
CU --  -----
CU
CU  5  THIS CARD IS ANALOGOUS TO THE 'CLD' CARD OF GM3D.
CU
CU  7  THIS TRACE NO. SHOULD ALWAYS BE THE 'LAGGING' TRACE FOR
CU     THIS CABLE LAYOUT.
CU
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (3) -- TRACE PROCESSING DENSITY
CU
CU    NO. OF CARDS:    REQUIRED = 0         ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |   0     |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'DEN'                                           |  REQ    |
CU  6  11-15 RECEIVER PROCESSING DENSITY                     |   1     |
CU  7  16-20 OUTPUT TRACE DENSITY                            |   1     |
CU                                                           -----------
CU DF  NOTES
CU --  -----
CU
CU  6  IF 2 IS SPECIFIED, ONLY EVERY OTHER RECEIVERS ARE PROCESSED.
CU     ALLOWED VALUES BETWEEN 1 AND 3.
CU
CU  7  IF 2 IS SPECIFIED, THERE WILL BE 2 TRACES OUTPUT FOR EACH
CU     SHOT LOCATION.
CU     ALLOWED VALUES BETWEEN 1 AND 3.
CU
CU  ** NOTE ** THE EFFECTIVE SHOT INTERVAL IS
CU                (G.I.) * (DF8-CARD1) * (DF9-CARD1)/100 / (DF7-CARD3)
CU             THE EFFECTIVE RECEIVER INTERVAL IS
CU                (G.I.) * (DF6-CARD3)
CU             THE EFFECTIVE SHOT INTERVAL HAS TO BE AN INTEGER
CU             MULTIPLIER OF THE EFFECTIVE RECEIVER INTERVAL
CU
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (4) -- SELECT SHOTPOINTS FOR FOCUSING ANALYSIS
CU
CU    NO. OF CARDS:    REQUIRED = 0         ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |   0     |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'FCS'                                           |  REQ    |
CU  6  11-15 STARTING SHOTPOINT FOR FOCUSING ANALYSIS        |  REQ    |
CU  7  16-20 ENDING   SHOTPOINT FOR FOCUSING ANALYSIS        |  REQ    |
CU  8  21-25 SHOTPOINT INCREMENT FOR FOCUSING ANALYSIS       |  REQ    |
CU  9  26-30 MAXIMUM DEPTH CORRECTION (FT) (ABSOLUTE)        |  REQ    |
CU 10  31-35 DEPTH CORRECTION STEP SIZE (FT)                 |NOTE DF10|
CU 11  36-40 AGC WINDOW LENGTH (MS)                          |NOTE DF11|
CU                                                           -----------
CU DF  NOTES
CU --  -----
CU
CU  5  THE OUTPUT OF FOCUSING ANALYSIS IS A PLOT OF THE INSTANEOUS
CU     AMPLITUDE OF ALL TRACES WITH RESPECT TO THE 'DEPTH CORRECTION'
CU     (HORIZONTAL) AXIS AND MIGRATED TIME (VERTICAL) AXIS.
CU     THE CENTRAL TRACE OF EACH SHOTPOINT ANALYSIS DISTINGUISHED BY A
CU     LOW BASE LINE CORRESPONDS TO THE ACTUAL RESULT OF THE MIGRATION
CU     WHICH GENERATED THE ANALYSIS.
CU     I.E. THE 'DEPTH CORRECTION' EQUAL TO ZERO.
CU
CU    EJECT
CU
CU     INTERPRETATION OF THE FOCUSING ANALYSIS:
CU     ---------------------------------------
CU
CU     (1)  ---------  DIRECTION OF PLOT  ---------->
CU
CU          -DF9                O                +DF9
CU                              I * * * * * * * * * *
CU                          *   I                   *
CU                      *       I                   *
CU                  *           I                   *
CU              *               I                   *
CU          *                   I                   *
CU          *     NEGATIVE      I     POSITIVE      *
CU          *       DEPTH       I       DEPTH       *
CU          *    CORRECTION     I    CORRECTION     *
CU          *                   I                   *
CU          *     DEPTH TOO     I     DEPTH TOO     *
CU          *       DEEP        I      SHALLOW      *
CU          *                   I                   *
CU          *     VELOCITY      I     VELOCITY      *
CU          *     TOO FAST      I     TOO SLOW      *
CU          *                   I                   *
CU          *                   I               *
CU          *                   I           *
CU          *                   I       *
CU          *                   I   *
CU          * * * * * * * * * * I
CU
CU
CU     (2)                      I
CU                              I           A
CU                              I         AABAA
CU           MIGRATED TIME T--> I........AAABBBAA
CU                              I         AAABAAA
CU                              I           AAA
CU                              I
CU                              I<----------->
CU                              I    DEPTH
CU                              I CORRECTION
CU
CU     (3)  THE VELOCITY CORRECTION FOR AVERAGE VELOCITIES IS EQUAL TO:
CU
CU               DV = 2*DZ/T
CU
CU 10  DEFAULT IS DF12 OF CARD 1.
CU
CU 11  THIS IS USED TO GAIN THE ENERGY FOR DISPLAY PURPOSES.
CU     DEFAULT IS NO AGC.
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (5) -- MODEL DEFINITION CARD (VELOCITY MODEL)
CU
CU    NO. OF CARDS:  REQUIRED = 1           ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |         |
CU  3    - 6 TYPE OF INTERPOLATION                           |   L     |
CU           'L' = LINEAR                                    |         |
CU           'S' = CUBIC SPLINE                              |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'MOD'                                           |  REQ    |
CU  6  11-15 MAXIMUM NUMBER OF HORIZONS                      |  REQ    |
CU  7  16-25 MINIMUM X IN LATERAL RANGE                      |  REQ    |
CU  8  26-35 MAXIMUM X IN LATERAL RANGE                      |  REQ    |
CU  9  36-45 SMALLEST ALGEBRAIC Z-VALUE IN VERTICAL RANGE    |  REQ    |
CU 10  46-55 LARGEST ALGEBRAIC Z-VALUE IN VERTICAL RANGE     |  REQ    |
CU 11  56-65 X-VALUE OF THE REFERENCE SHOTPOINT (DF13)       |NOTE DF11|
CU 12  66-70 THE RELATIVE DIRECTION OF THE SHOT X-COORDINATE |   +1    |
CU           (FROM CARD DF6 TO CARD DF7) AND THE MODEL       |         |
CU                +1:  SAME     DIRECTION AS THE MODEL       |         |
CU                -1:  OPPOSITE DIRECTION AS THE MODEL       |         |
CU 13  71-75 THE REFERENCE SHOTPOINT                         |NOTE DF13|
CU 14  76-80 NOT USED (RESERVED FOR DIVAS INPUT)             -----------
CU
CU DF  NOTES
CU --  -----
CU
CU 7-  FLOATING POINT VALUE IS OKAY.
CU 11
CU
CU 11  THE DEFAULT VALUE IS DF7.
CU
CU 12  EXAMPLE:
CU
CU     (1)  SHOT:         DF6                   DF7
CU         MODEL:      SMALLER X             LARGER X
CU         THEN  DF12 = +1
CU
CU     (2)  SHOT:         DF7                   DF6
CU         MODEL:      SMALLER X             LARGER X
CU         THEN  DF12 = -1
CU
CU 13  THE DEFAULT VALUE IS CARD(1) DF6.
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (6) -- DATUM ELEVATION/REPLACEMENT VELOCITY DEFINITION
CU
CU    NO. OF CARDS:  REQUIRED = 0           ALLOWED = NO LIMIT
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |         |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'DTM'                                           |  REQ    |
CU  6  11-20 DATUM ELEVATION                                 |   0     |
CU  7  21-30 REPLACEMENT VELOCITY                            | 10000   |
CU  8  31-80 NOT USED                                        |         |
CU                                                           -----------
CU  DF  NOTES
CU  --  -----
CU
CU   5  THE PURPOSE OF 'DTM' CARD IS TO MIGRATE TRACES FROM AN
CU      UNDULATING SURFACE.  THE DEPTH OF THE OUTPUT DEPTH SECTION
CU      STARTS FROM DF6. THE TIME OF THE TIME SECTION AND FOCUSING
CU      ANALYSIS TRACES IS RELATIVE TO THE TWO-WAY TRAVEL TIME FROM
CU      HORIZON #1.
CU
CU      THE SUGGESTED PROCESSING FLOW IS THE FOLLOWING:
CU      (1) INPUT A STACK SECTION TO DIVAS TO OBTAIN (X,Z) VALUES
CU          OF HORIZON #1,
CU      (2) RUN PROCESS 'TSHF' TO STATIC-SHIFT TRACES TO HORIZON #1,
CU      (3) RUN PROCESS 'VADM' WITH 'DTM' CARD.
CU
CU
CU   8  DF6 -> ----------------------------------1-  ZMIN (CARD4 DF9)
CU             |           V=DF7                1 |
CU             |   1111                       11  |
CU      HRZ#1  |111    11111111              1    |
CU             |               11111111     1     |
CU             |                       11111      |
CU             |                       11111      |
CU      HRZ#2  |22222                             |
CU             |     22222222222222               |
CU             |                   222222222222222|
CU             |                                  |
CU             ------------------------------------  ZMAX (CARD4 DF10)
CU
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (7) -- HORIZON DEFINITION CARD (VELOCITY MODEL)
CU
CU    NO. OF CARDS:  REQUIRED = 1           ALLOWED = NO LIMIT
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |         |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'HRZ'                                           |  REQ    |
CU  6  11-15 HORIZON NUMBER                                  |  REQ    |
CU  7  26-35 NOT USED                                        |         |
CU  8  36-45 FIXED VELOCITY ACROSS HORIZON                   |  OPT    |
CU  9  46-80 NOT USED                                        |         |
CU                                                           -----------
CU DF  NOTES
CU --  -----
CU  8  IF FIXED VELOCITY ACROSS THE ENTIRE HORIZON IS DEFINED
CU     ON THIS CARD, ANY VELOCITY DATA IN HORIZON SAMPLE CARDS
CU     INVOLVING THE HORIZON WILL BE IGNORED.
CU     FLOATING POINT VALUE IS OKAY.
CU
CU    EJECT
C=======================================================================
CU
CU    DATA CARD (8) -- HORIZON SAMPLE CARDS (VELOCITY MODEL)
CU
CU    NO. OF CARDS:  REQUIRED = 2           ALLOWED = NO LIMIT
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |         |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'BEG' = FIRST        SAMPLE CARD IN A SEGMENT   |  REQ    |
CU           '   ' = INTERMEDIATE SAMPLE CARD                |         |
CU           'END' = LAST         SAMPLE CARD IN A SEGMENT   |         |
CU  6  11-15 HORIZON NUMBER                                  |  REQ    |
CU  7  16-25 LATERAL  (X) POSITION                           |  REQ    |
CU  8  26-35 VERTICAL (Z) POSITION                           |NOTE DF8 |
CU  9  36-45 VELOCITY UNDER HORIZON AT COORDINATE X          |NOTE DF8 |
CU 10  46-80 NOT USED                                        |         |
CU                                                           -----------
CU
CU DF  NOTES
CU --  -----
CU  5  EACH SUBSURFACE HORIZON IS COMPRISED OF ONE OR MORE LINE
CU     SEGMENTS.  A SEGMENTS IS DELINEATED BY A BEG AND AN END
CU     SAMPLE CARD.  WITHIN EACH LINE SEGMENT, ANY NUMBER OF
CU     INTERMEDIATE SAMPLE CARDS MAY BE INSERTED.
CU
CU     ALL BEG, INTERMEDIATE AND END SAMPLE CARDS MUST APPEAR IN
CU     ORDER OF INCREASING LATERAL POSITION.
CU
CU  7  FOLATING POINT VALUE IS OKAY.
CU -9
CU
CU  8  THE X-Z VALUES OF THIS CARD TYPE ARE USED TO DEFINE THE
CU     GEOMETRY OF THE SUBSURFACE HORIZON.  THE INTERVAL
CU     VELOCITIES, HOWEVER, REQUIRE ONLY THE X LOCATION VALUE AS
CU     THEY REPRESENT PROPERTIES OF THE MATERIAL BENEATH THE
CU     HORIZON AT THE LATERAL POSITION SPECIFIED REGARDLESS OF
CU     THE Z POSITION OF THE HORIZON.  CONSEQUENTLY, THE Z VALUE
CU     SHOULD ONLY BE SPECIFIED WHEN THE GEOMETRY OF THE
CU     HORIZON IS BEING DEFINED (AS OPPOSED TO THE SIMPLE
CU     SPECIFICATION OF INTERVAL VELOCITY).
CU
CU    EJECT
C=======================================================================
CU
CU      DATA CARD (9) -- END OF VELOCITY MODEL (VELOCITY MODEL)
CU
CU      NO. OF CARDS:  REQUIRED = 1         ALLOWED = 1
CU
CU                                                           REQ OR OPT
CU DF  COLS  DEFINITION                                      OR DEFAULT
CU --  ----- ----------                                      -----------
CU  1   1- 4 'VADM'                                          |  REQ    |
CU  2    - 5 PROCESS NUMBER                                  |         |
CU  3    - 6 NOT USED                                        |         |
CU  4    - 7 NOT USED                                        |         |
CU  5   8-10 'EXT'                                           |  REQ    |
CU  6  11-80 NOT USED                                        |         |
CU                                                           -----------
C=======================================================================
C
C              FORMAT OF INPUT PARAMETER RECORDS
C
C   ****** FIRST RECORD, PROCESSING PARAMETERS ************
C
C  WORD 1  WORD 2   WORD 3  WORD 4  WORD 5  WORD 6  WORD 7  WORD 8
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  |  VADM | PROCESS|  PTS  |  NOT  |  NOT  | # OF  |  NOT  |  NOT  |
C  |_______|_NUMBER_|_______|__USED_|__USED_|_PARMS_|__USED_|__USED_|
C
C  WORD 9  WORD 10  WORD 11 WORD 12 WORD 13 WORD 14 WORD 15 WORD 16
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  | ISBEG | ISEND  | IDXSS |  IFLO |  IFHI |   DZ  | IZMAX | IGBEG |
C  |_______|________|_______|_______|_______|_______|_______|_______|
C
C  WORD 17 WORD 18  WORD 19 WORD 20 WORD 21 WORD 22 WORD 23 WORD 24
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  | IGEND |   MG   | IDXGG | LOCSHT|  NG   | ISFBEG| ISFEND| ISFINC|
C  |_______|________|_______|_______|_______|_______|_______|_______|
C
C  WORD 25 WORD 26  WORD 27 WORD 28 WORD 29 WORD 30 WORD 31 WORD 32
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  | NSFCS | IZCORR |ISCTRL |  IDIP |  IDZC | ISINC | NUMH  | IDZ0  |
C  |_______|________|_______|_______|_______|_______|_______|_______|
C
C  WORD 33 WORD 34  WORD 35 WORD 36 WORD 37 WORD 38 WORD 39 WORD 40
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  | LOPR  | IWAGC  | MINDX | MAXDX | MZDIF | NTRNC | ZDTM  | VDTM  |
C  |_______|________|_______|_______|_______|_______|_______|_______|
C
C  WORD 41 WORD 42  WORD 43 WORD 44 WORD 45
C  |_______|________|_______|_______|_______|
C  | ICDTM |  JSSO  | JSADV | JSINC | JSFINC|
C  |_______|________|_______|_______|_______|
C
C
C   ****** FOLLOWING RECORDS ******* CLD ************
C
C  WORD 1  WORD 2   WORD 3  WORD 4  WORD 5  WORD 6  WORD 7  WORD 8
C  |_______|________|_______|_______|_______|_______|_______|_______|
C  |  VADM | PROCESS|  CLD  |  NOT  |  NOT  | # OF  |NO. OF |  NOT  |
C  |_______|_NUMBER_|_______|__USED_|__USED_|_PARMS_|CLD_REC|__USED_|
C
C  WORD 9  WORD 10   .....WORD XX
C  |_______|________|.....|_________|
C  | INDX  | INDX   |.....| INDX    |
C  |_(IG=1)|_(IG=2)_|.....|_(IG=MG)_|
C
C=======================================================================
C     EJECT
C
      SUBROUTINE SPVADM
C
      IMPLICIT INTEGER (A-Z)
C
C     COMMON  /P/  STATEMENTS GENERATED BY UTCGI4             11/28/83
      COMMON  /P/  STARTP (               2)           , M00000(    2)
      COMMON  /P/  LCINT
      COMMON  /P/  LCTYP                               , M00020(    6)
      COMMON  /P/  LCTPSP
      COMMON  /P/  LCRL
      COMMON  /P/  LCSI
      COMMON  /P/  LCPI
      COMMON  /P/  LCGRPI
      COMMON  /P/  LCMXFD                              , M00068(   13)
      COMMON  /P/  ACLNAM (               5)           , M00124(   68)
      COMMON  /P/  KPNA
      COMMON  /P/  KPRNO                               , M00420(   14)
      COMMON  /P/  KPIUSM
      COMMON  /P/  KPNUSM
      COMMON  /P/  KPTIME
      COMMON  /P/  KPRTF                               , M00492(    8)
      COMMON  /P/  KPPRNT                              , M00528(    2)
      COMMON  /P/  KPBUGF                              , M00540(  226)
      COMMON  /P/  ENDP
C
      COMMON  / SYSTEM / SYSTEM, SYBYPW,SYLOCF
C
      COMMON COM(1)
C
C===================================================================
C                    INTEGER ARRAYS -- LOCAL
C===================================================================
C
      INTEGER      DATTR   (96)
      INTEGER      DENTRY  (104)
      INTEGER      INDX    (960)
C
C===================================================================
C                    REAL ARRAYS AND VARIABLE -- LOCAL
C===================================================================
C
      REAL         LCGRPI
      REAL         DZ
      REAL         DZC
      REAL         ZDTM
      REAL         VDTM
      REAL         ZMIN
      REAL         AENTRY (104)
C
      REAL         TEMP
C
C===================================================================
C                      EQUIVALENCES
C===================================================================
C
      EQUIVALENCE  (AENTRY(1),DENTRY (01))
C
      EQUIVALENCE  (DCTYP,    DENTRY (03))
      EQUIVALENCE  (NOPAR,    DENTRY (06))
      EQUIVALENCE  (DATTR(1), DENTRY (09))
C
C=================================================================
C                 CHARACTER CONSTANTS AND ARRAYS
C=================================================================
C
      CHARACTER*80  CARD
C
C=================================================================
C                 DATA STATEMENTS
C=================================================================
C
      DATA          DATTR          /96 * 0/
C
C
C
C
C
C ======================================================================
C                       INITIALIZATION
C ======================================================================
C
      DAP     = 1
      NOREC   = 0
      IPR     = KPPRNT
C
C
      NS=LCRL/LCPI
C
C
C ======================================================================
C        PRINT HEADING
C ======================================================================
C
      CALL USPHD (1, ACLNAM, KPNA, KPRNO, 0, 0, IPR)
C
C     IF(S1CPCH(SYSTEM, 1, 'CRAY', 1, 4) .NE. 0) WRITE(IPR,9000)
C
C ======================================================================
C        READ INPUT CARD (3) ('DEN' CARD)
C ======================================================================
C
      JGGI = 1
      JSSO = 1
C
      DAC = 1
    5 CALL FORC (KPNA, KPRNO, DAC, CARD,                           * 6)
      IF (S1CPCH (CARD, 8, 'DEN', 1, 3) .NE. 0) GO TO                5
C
      IF (S1CPCH (CARD, 11, '     ', 1, 5) .NE. 0)
     +      JGGI = S1CVBN(CARD,11,5)
      IF (S1CPCH (CARD, 16, '     ', 1, 5) .NE. 0)
     +      JSSO = S1CVBN(CARD,16,5)
C
    6 CONTINUE
      WRITE(IPR,9001) JGGI,JSSO
C
      IF(JGGI.LT.1 .OR. JGGI.GT.3) GO TO                          8120
      IF(JSSO.LT.1 .OR. JSSO.GT.3) GO TO                          8130
C
C ======================================================================
C        READ INPUT CARD (1)
C ======================================================================
C
      DAC = 1
   10 CALL FORC (KPNA, KPRNO, DAC, CARD,                        * 8010)
      IF (S1CPCH (CARD, 8, '   ', 1, 3) .NE. 0) GO TO               10
      IF (S1CPCH (CARD, 7, 'S', 1, 1) .NE. 0) GO TO               8020
C
      ISBEG = S1CVBN(CARD,11,5)
      ISEND = S1CVBN(CARD,16,5)
      ISINC = S1CVBN(CARD,21,5)
      ISADV = S1CVBN(CARD,26,5)
      IFLO  = S1CVBN(CARD,31,5)
      IFHI  = S1CVBN(CARD,36,5)
C     IDZ   = S1CVBN(CARD,41,5)
      CALL USCHFT(CARD,41,5,DZ)
      IZMAX = S1CVBN(CARD,46,5)
      IDIP  = S1CVBN(CARD,51,5)
      LOPR  = S1CVBN(CARD,56,5)
      IDCLD = S1CVBN(CARD,61,5)
      IDZ0  = S1CVBN(CARD,66,5)
      MZDIF = S1CVBN(CARD,71,5)
      NTRNC = S1CVBN(CARD,76,5)
C
      IF (ISBEG .EQ. 0) GO TO                                     8030
      IF (ISEND .EQ. 0) GO TO                                     8040
      IF (ISADV .EQ. 0) ISADV=100
      IF (IFLO  .EQ. 0) GO TO                                     8060
      IF (IFHI  .EQ. 0) GO TO                                     8070
      IF (DZ    .EQ. 0) GO TO                                     8080
      IF (IDIP  .EQ. 0) GO TO                                     8095
      IF (IDCLD .EQ. 0) GO TO                                     8096
      IF (ISINC .EQ. 0) ISINC = 1
      IF (LOPR  .EQ. 0) LOPR  = 1
C
      IF(MZDIF.EQ.0) MZDIF=2
      MZDIF=MAX0(MZDIF,1)
      MZDIF=MIN0(MZDIF,4)
C
      NTRNC=MAX0(NTRNC,2)
      NTRNC=MIN0(NTRNC,4)
C
      IF (LCGRPI .EQ. 0.) GO TO                                   8100
C
      IF (MOD(ISADV,100) .NE. 0) GO TO                            8150
C
      JSINC=ISINC
      JSADV=ISADV
      IF(MOD(ISINC,JSSO) .EQ. 0) THEN
        JSINC=ISINC/JSSO
        JJSSO= JSSO
      ELSE IF(MOD(ISADV,JSSO*100) .EQ. 0) THEN
        JSADV=ISADV/JSSO
        JJSSO=-JSSO
      ELSE
        GO TO                                                     8140
      ENDIF
      JSSO=JJSSO
C
C
      LOPR=(LOPR-1)/2
      LOPR=LOPR*2+1
C
C     IDXGG = LCGRPI+.5
      IDXGG = LCGRPI*100.+0.5
C
C     IDXSS = IDXGG*ISADV/100
      IDXSS = IDXGG*ISADV*IABS(ISINC)/100
C
C
      JDXGG = IDXGG*JGGI
      JDXSS = IDXSS/IABS(JSSO)
      WRITE(IPR,2010) JSADV,JSINC,JSSO,JDXSS
C
      IF(JDXSS.LT.JDXGG) THEN
        GO TO                                                     8110
      ENDIF
C
C
      IF(ISBEG.LT.ISEND .AND. ISINC.LT.0) THEN
      GO TO                                                       8151
      ENDIF
      IF(ISBEG.GT.ISEND .AND. ISINC.GT.0) THEN
      GO TO                                                       8151
      ENDIF
      WRITE(IPR,2001) ISBEG,ISEND,ISINC,ISADV,IFLO,IFHI,
     *                DZ,IZMAX,IDIP,IDCLD,IDXSS,LOPR,MZDIF,NTRNC
C
      IS00=MIN0(ISBEG,ISEND)
      IS11=MAX0(ISBEG,ISEND)
C
      I85=+1
      IF(IDIP.LE.0) THEN
        I85=-1
        IDIP=-IDIP
      ENDIF
C
C ======================================================================
C        READ INPUT CARD (2)
C ======================================================================
C
C
      DAC = 1
   20 CALL FORC (KPNA, KPRNO, DAC, CARD,                         *8200)
      IF(S1CPCH(CARD,8,'CLD',1,3) .NE. 0) GO TO                     20
      JDCLD = S1CVBN(CARD,11,5)
      IF(JDCLD.NE.IDCLD) GO TO                                      20
C
C
      K = 0
      DO 50 I = 16, 80, 5
      K = K + 1
      IF (S1CPCH (CARD,I+4,'X',1,1).NE.0) GO TO                     30
      LOCSAV = K
      INDX(K) = -999
      GO TO 50
   30 IF (S1CPCH (CARD,I,'     ',1,5).EQ.0) GO TO                   40
      INDX(K) = S1CVBN (CARD,I,5)
      GO TO                                                         50
   40 K = K -1
   50 CONTINUE
      WRITE(IPR,2002) LOCSAV,K,(INDX(I),I=1,K)
C
C     S--R-R-R.......
C
      IF(LOCSAV .EQ. 1) THEN
      DO 100 I=4,K,2
  100 IF(INDX(I) .NE. 100) GO TO                                  8210
C
      II1=INDX(2)/JGGI
      II2=(INDX(2)+INDX(4))/JGGI
      IF(MOD(II1,100) .LE. MOD(II2,100)) THEN
        INDX(2)=II1
      ELSE
        INDX(2)=II2
        INDX(3)=INDX(3)+ISIGN(1,INDX(K)-INDX(3))
      ENDIF
        INDX(K)=INDX(K)-MOD(INDX(K)-INDX(3),JGGI)
C
      IGBEG=INDX(3)
      IGEND=INDX(K)
      IG00=MIN0(IGBEG,IGEND)
      JGBEG=IGBEG-IG00+1
      JGEND=IGEND-IG00+1
C     IDXSG=(INDX(2)+50)/100*IDXGG
      INDX(2)=(INDX(2)+50)/100
      IDXSG=INDX(2)*JDXGG
      INDX(2)=INDX(2)*100
      WRITE(IPR,2002) LOCSAV,K,(INDX(I),I=1,K)
C
      INC=+JGGI
      IF(IGEND.LT.IGBEG) INC=-JGGI
      CALL ARSET(INDX,960,-9999)
      JX=IDXSG/JDXGG
      DO 101 IG=JGBEG,JGEND,INC
      JX=JX+1
  101 INDX(IG)=JX
      NG=INDX(JGEND)
      DO 102 IG=1,NG
  102 INDX(IG)=INDX(IG)+10
C
      LOCSHT=1
        IF(NG.NE.1) THEN
        NG=NG+10
        LOCSHT=11
        ISCTRL=1
        ENDIF
C
C     ......R-R-R--S
C
      ELSE IF(LOCSAV .EQ. K) THEN
      DO 110 I=2,K-3,2
  110 IF(INDX(I) .NE. 100) GO TO                                  8210
C
C     INDX(1)=INDX(1)-MOD(INDX(1)-INDX(K-2),JGGI)
C     INDX(K-1)=INDX(K-1)/JGGI
      II1=INDX(K-1)/JGGI
      II2=(INDX(K-1)+INDX(K-3))/JGGI
      IF(MOD(II1,100) .LE. MOD(II2,100)) THEN
        INDX(K-1)=II1
      ELSE
        INDX(K-1)=II2
        INDX(K-2)=INDX(K-2)+ISIGN(1,INDX(1)-INDX(K-2))
      ENDIF
        INDX(1)=INDX(1)-MOD(INDX(1)-INDX(K-2),JGGI)
C
      IGBEG=INDX(1)
      IGEND=INDX(K-2)
      IG00=MIN0(IGBEG,IGEND)
      JGBEG=IGBEG-IG00+1
      JGEND=IGEND-IG00+1
C     IDXSG=(INDX(K-1)+50)/100*IDXGG
      INDX(K-1)=(INDX(K-1)+50)/100
      IDXSG=INDX(K-1)*JDXGG
      INDX(K-1)=INDX(K-1)*100
      WRITE(IPR,2002) LOCSAV,K,(INDX(I),I=1,K)
C
      INC=+JGGI
      IF(IGEND.LT.IGBEG) INC=-JGGI
      CALL ARSET(INDX,960,-9999)
      JX=0
      DO 111 IG=JGBEG,JGEND,INC
      JX=JX+1
  111 INDX(IG)=JX
C
C     WRITE(IPR,9971) INDX(JGEND),IDXSG,JDXGG,INC
C9971 FORMAT(' INDX(JGEND),IDXSG,JDXGG,INC =',4I5)
C     NG=INDX(JGEND)+IDXSG/IDXGG
      NG=INDX(JGEND)+IDXSG/JDXGG
C     WRITE(IPR,9972) NG
C9972 FORMAT('  NG =',I5)
        IF(NG.NE.1) THEN
        LOCSHT=NG
        NG=NG+10
        ISCTRL=2
        ENDIF
C
C     R-R-R...--S--...R-R-R
C
      ELSE
C
      DO 120 I=2,LOCSAV-3,2
  120 IF(INDX(I) .NE. 100) GO TO                                  8210
      DO 121 I=LOCSAV+3,K,2
  121 IF(INDX(I) .NE. 100) GO TO                                  8210
C
C     IDXGSG=INDX(LOCSAV-1)+INDX(LOCSAV+1)
C
C     WRITE(IPR,6002) LOCSAV,K,IPR,(INDX(I),I=1,K)
C
C     IF(INDX(LOCSAV-1) .LE. INDX(LOCSAV+1)) THEN
      II1=INDX(LOCSAV-1)/JGGI
      II2=INDX(LOCSAV+1)/JGGI
      IF(MOD(II1,100) .LE. MOD(II2,100)) THEN
        ITEMP=INDX(LOCSAV-2)
        INDX(LOCSAV-1)=INDX(LOCSAV-1)/JGGI
C       INDX(LOCSAV+1)=(INDX(LOCSAV+1)+100)/JGGI
        INDX(LOCSAV+1)=(INDX(LOCSAV+1)+100*(JGGI-1))/JGGI
        INDX(LOCSAV+2)=INDX(LOCSAV+2)+1*(JGGI-1)
      ELSE
        ITEMP=INDX(LOCSAV+2)
        INDX(LOCSAV+1)=INDX(LOCSAV+1)/JGGI
C       INDX(LOCSAV-1)=(INDX(LOCSAV-1)+100)/JGGI
        INDX(LOCSAV-1)=(INDX(LOCSAV-1)+100*(JGGI-1))/JGGI
        INDX(LOCSAV-2)=INDX(LOCSAV-2)-1*(JGGI-1)
      ENDIF
C     INDX(1)=INDX(1)-MOD(INDX(1)-INDX(ITEMP),JGGI)
C     INDX(K)=INDX(K)-MOD(INDX(K)-INDX(ITEMP),JGGI)
      INDX(1)=INDX(1)-MOD(INDX(1)-ITEMP,JGGI)
      INDX(K)=INDX(K)-MOD(INDX(K)-ITEMP,JGGI)
C
        TEMP=FLOAT(INDX(LOCSAV-1)+INDX(LOCSAV+1))/100.
        ITEMP=NINT(TEMP)*100
C       WRITE(IPR,1111) INDX(LOCSAV-1),INDX(LOCSAV+1),TEMP,ITEMP
C1111   FORMAT(' -1,+1 =',2I5,' TEMP =',E12.5,' ITEMP =',I5)
C
        INDX(LOCSAV-1)=(INDX(LOCSAV-1)+50)/100
        INDX(LOCSAV-1)=INDX(LOCSAV-1)*100
C       INDX(LOCSAV+1)=(INDX(LOCSAV+1)+50)/100
C       INDX(LOCSAV+1)=INDX(LOCSAV+1)*100
        INDX(LOCSAV+1)=ITEMP-INDX(LOCSAV-1)
CJCS
C     IDXGSG=INDX(LOCSAV-1)+INDX(LOCSAV+1)
C     INDX(LOCSAV-1)=(INDX(LOCSAV-1)+50)/100
C     INDX(LOCSAV-1)=INDX(LOCSAV-1)*100
C     INDX(LOCSAV+1)=(INDX(LOCSAV+1)+50)/100
C     INDX(LOCSAV+1)=INDX(LOCSAV+1)*100
      WRITE(IPR,2002) LOCSAV,K,(INDX(I),I=1,K)
      IDXGSG=INDX(LOCSAV-1)+INDX(LOCSAV+1)
      IF(MOD(IDXGSG,100) .NE. 0) GO TO                            8210
      IGBEG=INDX(1)
      IGEND=INDX(K)
      IG00=MIN0(IGBEG,IGEND)
      JGBEG=IGBEG-IG00+1
      JGEND=IGEND-IG00+1
      IDXGS=(INDX(LOCSAV-1)+50)/100*JDXGG
C     WRITE(IPR,6003) IDXGSG,IGBEG,IGEND,IG00,JGBEG,JGEND,IDXGS
C6003 FORMAT(/,'  $$ IDXGSG =',I5,/,
C    +         '  $$  IGBEG =',I5,/,
C    +         '  $$  IGEND =',I5,/,
C    +         '  $$  IG00  =',I5,/,
C    +         '  $$  JGBEG =',I5,/,
C    +         '  $$  JGEND =',I5,/,
C    +         '  $$  IDXGS =',I5)
C     WRITE(IPR,6002) LOCSAV,K,IPR,(INDX(I),I=1,K)
C6002 FORMAT(/,'  @@ LOCSAV =',I5,/,
C    +          ' @@  K      =',I5,/,
C    +          ' @@  IPR    =',I5,/,
C    +          ' @@  INDX   =',10I5)
C
      INC=+JGGI
      IF(IGEND.LT.IGBEG) INC=-JGGI
C
      JG2=INDX(LOCSAV-2)-IG00+1
      JG3=INDX(LOCSAV+2)-IG00+1
      CALL ARSET(INDX,960,-9999)
C     WRITE(IPR,6004) INC,JGGI,JG2,JG3,LOCSHT,NG
C     CALL PTST1I('INDX',INDX,960,IPR)
      JX=0
      DO 122 IG=JGBEG,JG2,INC
      JX=JX+1
  122 INDX(IG)=JX
C     WRITE(IPR,6004) INC,JGGI,JG2,JG3,LOCSHT,NG
C6004 FORMAT(/,'  $$  INC   =',I5,/,
C    +         '  $$  JGGI  =',I5,/,
C    +         '  $$  JG2   =',I5,/,
C    +         '  $$  JG3   =',I5,/,
C    +         '  $$  LOCSHT=',I5,/,
C    +         '  $$  NG    =',I5)
C     CALL PTST1I('INDX',INDX,960,IPR)
C     III=1
C     IF(III.EQ.1) THEN
C       GO TO 9999
C     ENDIF
      LOCSHT=INDX(JG2)+IDXGS/JDXGG
      JX=INDX(JG2)+IDXGSG/100
      DO 123 IG=JG3,JGEND,INC
      INDX(IG)=JX
  123 JX=JX+1
      NG=INDX(JGEND)
      ISCTRL=0
C
C
      ENDIF
C
      IRATIO=JDXSS/JDXGG
      MODNG=MOD(NG,IRATIO)
      IF(MODNG .NE. 0) THEN
      NG=NG+(IRATIO-MODNG)
      ENDIF
C
      MG=MAX0(JGBEG,JGEND)
C
      DO 126 I=1,MG
  126 INDX(I)=MAX0(INDX(I),0)
C
C
      I1=1
  124 IF(INDX(I1) .EQ. 0) THEN
       I1=I1+1
       GO TO                                                       124
      ENDIF
      I2=MG
  125 IF(INDX(I2) .EQ. 0) THEN
       I2=I2-1
       GO TO                                                       125
      ENDIF
C
      MINDX=MIN0(INDX(I1),INDX(I2))
      MAXDX=MAX0(INDX(I1),INDX(I2))
      WRITE(IPR,2003) IGBEG,IGEND,MG,LOCSHT,NG,JDXGG,MINDX,MAXDX
      WRITE(IPR,2004) (INDX(I),I=1,MG)
C
C ======================================================================
C        READ INPUT CARD (3)
C ======================================================================
C
C
C
      NSFCS=0                                                           04230028
      DAC = 1
   60 CALL FORC (KPNA, KPRNO, DAC, CARD,                          * 70)
      IF(S1CPCH(CARD,8,'FCS',1,3) .NE. 0) GO TO                     60
C
      ISFBEG = S1CVBN (CARD, 11, 5 )
      ISFEND = S1CVBN (CARD, 16, 5 )
      ISFINC = S1CVBN (CARD, 21, 5 )
      IZCORR = S1CVBN (CARD, 26, 5 )
C     IDZC   = S1CVBN (CARD, 31, 5 )
      CALL USCHFT (CARD, 31, 5 ,DZC)
      IWAGC  = S1CVBN (CARD, 36, 5 )
C
      ISF00=MIN0(ISFBEG,ISFEND)
      ISF11=MAX0(ISFBEG,ISFEND)
      ISFINC=ISIGN(ISFINC,ISINC)
      IF(ISINC.GE.0) THEN
      ISFBEG=ISF00
      ISFEND=ISF11
      ELSE
      ISFBEG=ISF11
      ISFEND=ISF00
      ENDIF
C
C     IF(DZC.EQ.0.) DZC=DZ/2
      IF(DZC.EQ.0.) DZC=DZ
C
        IF(MOD(ISFBEG-ISBEG,ISINC) .NE. 0) THEN
          ISFBEG=IFIX(FLOAT((ISFBEG-ISBEG)/ISINC+1))*ISINC+ISBEG
        ENDIF
      IF(ISINC.GE.0) THEN
          ISFINC=IFIX(FLOAT((ISFINC+ISINC-1)/ISINC))*ISINC
      ELSE
          ISFINC=IFIX(FLOAT((ISFINC+ISINC+1)/ISINC))*ISINC
      ENDIF
C
C
      IF( ISF00.LT.IS00 .OR. ISF11.GT.IS11 ) THEN                       04240028
         GO TO                                                    8700  04250028
      ELSE IF (ISFBEG.EQ.ISFEND) THEN                                   04260028
         NSFCS = 1                                                      04270028
         ISFINC = 0                                                     04280028
         WRITE(IPR,2005) ISFBEG,ISFEND,ISFINC,NSFCS,IZCORR,DZC,IWAGC    04290028
      ELSE IF (ISFINC .EQ. 0) THEN                                      04300028
         GO TO                                                    8700  04310028
      ELSE                                                              04320028
         NSFCS=(ISFEND-ISFBEG)/ISFINC+1                                 04330028
         WRITE(IPR,2005) ISFBEG,ISFEND,ISFINC,NSFCS,IZCORR,DZC,IWAGC    04290028
      ENDIF                                                             04350028
C     GO TO                                                         80
C
C  70 WRITE(IPR,2006)
C     ISFBEG = 0
C     ISFEND = 0
C     ISFINC = 0
C
C  80 CONTINUE
C
C
C     IF(NSFCS.GT.LCMXFD) THEN
C
      NZF=INT((2.*FLOAT(IZCORR)+0.0001)/DZC)+1
      IF(NZF.GT.LCTPSP) THEN
        GO TO                                                     8710
      ENDIF
C
      IF (ISFINC.NE.0) THEN
        KSINC=ISFINC/ISINC
        IF(KSINC.LE.0) GO TO                                      8155
      ENDIF
C
      IF (NSFCS.NE.0 .AND. IZCORR.EQ.0) GO TO                     8160
C
      GO TO                                                         80
C
   70 WRITE(IPR,2006)
      ISFBEG = 0
      ISFEND = 0
      ISFINC = 0
C
   80 CONTINUE
C
C ======================================================================
C        READ INPUT CARD (4)
C ======================================================================
C
      DAC = 1
   90 CALL FORC (KPNA, KPRNO, DAC, CARD,                        * 8600)
      IF(S1CPCH(CARD,8,'MOD',1,3) .NE. 0) GO TO                     90
      NUMH   = S1CVBN (CARD, 11, 5 )
      CALL USCHFT (CARD, 36, 10 ,ZMIN)
      WRITE(IPR,2007) NUMH
C
C ======================================================================
C        READ INPUT CARD (5)
C ======================================================================
C
      ICDTM=0
      ZDTM=0.
      VDTM=0.
C
      DAC = 1
  200 CALL FORC (KPNA, KPRNO, DAC, CARD,                         * 210)
      IF(S1CPCH(CARD,8,'DTM',1,3) .NE. 0) GO TO                    200
      ICDTM=1
      CALL USCHFT (CARD, 11, 10 ,ZDTM)
      CALL USCHFT (CARD, 21, 10 ,VDTM)
      IF(NINT(ZDTM).NE.NINT(ZMIN)) GO TO                           8650
      WRITE(IPR,2008) ZDTM,VDTM
C
  210 CONTINUE
      NZ=INT((IZMAX-ZDTM+0.00001)/DZ)
      WRITE(IPR,2009) NZ
      IF(NZ.LE.1) GO TO                                           8090
      IF(NZ.GT.NS) GO TO                                          8091
      NGS=(NG-1)/IRATIO
      ICOM=KPIUSM
      CALL SPVADMA(COM(ICOM),ISBEG,ISEND,ISINC,IDXSS,NGS,NZ,DZ,NUMH,
     +            ZDTM,VDTM,KPNA,KPRNO,KPNUSM,CARD,IABT,IPR)
      IF(IABT .NE. 0) GO TO                                       8800
C
C ======================================================================
C                      PREPARE 'PTS' RECORD
C ======================================================================
C
      DENTRY(1) = KPNA
      DENTRY(2) = KPRNO
C
      CALL S1MVCH ('PTS', 1, DCTYP, 1, 3)
C
      CALL ARSET (DATTR, 96, 0)
C
      IF(JSSO.LE.-2) THEN
        JSBEG=ISBEG
        JSEND=(ISEND-ISBEG)*IABS(JSSO)+ISBEG
        JSFBEG=(ISFBEG-ISBEG)*IABS(JSSO)+ISBEG
        JSFEND=(ISFEND-ISBEG)*IABS(JSSO)+ISBEG
        JSFINC=ISFINC*JSSO
      ELSE
        JSBEG=ISBEG
        JSEND=ISEND
        JSFBEG=ISFBEG
        JSFEND=ISFEND
        JSFINC=ISFINC
      ENDIF
C
C
C**** SET NO. OF PARAMETERS ON THIS RECORD
C
      NOPAR = 40
C
      DATTR( 1) = JSBEG
      DATTR( 2) = JSEND
      DATTR( 3) = JDXSS
      DATTR( 4) = IFLO
      DATTR( 5) = IFHI
C     DATTR( 6) = IDZ
      AENTRY(14) = DZ
      DATTR( 7) = IZMAX
      DATTR( 8) = IGBEG
      DATTR( 9) = IGEND
      DATTR(10) = MG
      DATTR(11) = JDXGG
      DATTR(12) = LOCSHT
      DATTR(13) = NG
      DATTR(14) = JSFBEG
      DATTR(15) = JSFEND
      DATTR(16) = JSFINC
      DATTR(17) = NSFCS
      DATTR(18) = IZCORR
      DATTR(19) = ISCTRL
      DATTR(20) = IDIP
C     DATTR(21) = IDZC
      AENTRY(29) = DZC
      DATTR(22) = JSINC
      DATTR(23) = NUMH
      DATTR(24) = IDZ0
      DATTR(25) = LOPR
      DATTR(26) = IWAGC
      DATTR(27) = MINDX
      DATTR(28) = MAXDX
      DATTR(29) = MZDIF
      DATTR(30) = NTRNC
      AENTRY(39) = ZDTM
C
      DATTR(32) = JSSO
      DATTR(33) = ISBEG
      DATTR(34) = ISEND
      DATTR(35) = ISINC
      DATTR(36) = IDXSS
      DATTR(37) = ISFBEG
      DATTR(38) = ISFEND
      DATTR(39) = ISFINC
      DATTR(40) = I85
C
      CALL FOWP (KPNA, KPRNO, DAP, 104, DENTRY, * 8500 )
      NOREC = NOREC + 1
C
C
C ======================================================================
C                      PREPARE 'CLD' RECORD
C ======================================================================
C
      CALL S1MVCH ('CLD', 1, DCTYP, 1, 3 )
C
      NOCLD = (MG + 95) / 96
      DENTRY(7) = NOCLD
C
      I1 = 1
C
        DO 500 ICLD = 1, NOCLD
        CALL ARSET (DATTR, 96, 0 )
        NOPAR = MIN0(96, MG-I1+1 )
        CALL SCOPY (NOPAR, INDX(I1), 1, DATTR, 1 )
        I1 = I1 + 96
        CALL FOWP (KPNA, KPRNO, DAP, 104, DENTRY,               * 8500)
  500   NOREC = NOREC + 1
C
C
C =====================================================================
C                    NORMAL TERMINATION
C =====================================================================
C
C
      IF (KPBUGF .NE. 0) THEN
        DAP = 1
  600   CALL FORP (KPNA, KPRNO, DAP, 104, DENTRY,                * 700)
        WRITE (IPR, 9300) DENTRY
        GO TO                                                      600
  700   CONTINUE
      ENDIF
C
      WRITE (IPR, 9400) KPNA, KPRNO, NOREC
C
      RETURN
C
C =====================================================================
C                           ERROR EXITS
C =====================================================================
C
 8010 WRITE (IPR, 9010 ) KPNA, KPRNO
      GO TO                                                       9999
C
 8020 WRITE (IPR, 9020 )
      GO TO                                                       9999
C
 8030 WRITE (IPR, 9030 )
      GO TO                                                       9999
C
 8040 WRITE (IPR, 9040 )
      GO TO                                                       9999
C
 8060 WRITE (IPR, 9060 )
      GO TO                                                       9999
C
 8070 WRITE (IPR, 9070 )
      GO TO                                                       9999
C
 8080 WRITE (IPR, 9080 )
      GO TO                                                       9999
C
 8090 WRITE (IPR, 9090 ) NZ,ZDTM,IZMAX
      GO TO                                                       9999
C
 8091 WRITE (IPR, 9091 ) NZ,NS
      GO TO                                                       9999
C
 8095 WRITE (IPR, 9095 )
      GO TO                                                       9999
C
 8096 WRITE (IPR, 9096 )
      GO TO                                                       9999
C
 8100 WRITE (IPR, 9100 )
      GO TO                                                       9999
C
 8110 WRITE (IPR, 9110 ) JDXSS,JDXGG
      GO TO                                                       9999
C
 8120 WRITE (IPR, 9120 )
      GO TO                                                       9999
C
 8130 WRITE (IPR, 9130 )
      GO TO                                                       9999
C
 8140 WRITE (IPR, 9140 )
      GO TO                                                       9999
C
 8150 WRITE (IPR, 9150 )
      GO TO                                                       9999
C
 8151 WRITE (IPR, 9151 ) ISBEG,ISEND,ISINC
      GO TO                                                       9999
C
 8155 WRITE (IPR, 9155 ) ISFINC, ISINC
      GO TO                                                       9999
C
 8160 WRITE (IPR, 9160 )
      GO TO                                                       9999
C
 8200 WRITE (IPR, 9200 ) KPNA, KPRNO
      GO TO                                                       9999
C
 8210 WRITE (IPR, 9210 ) LOCSAV,K,(INDX(I),I=1,K)
      GO TO                                                       9999
C
 8500 WRITE (IPR, 9500 )
      GO TO                                                       9999
C
 8600 WRITE (IPR, 9600 ) KPNA, KPRNO
      GO TO                                                       9999
C
 8650 WRITE (IPR, 9650 ) ZMIN, ZDTM
      GO TO                                                       9999
C
 8700 WRITE (IPR, 9700 )
      GO TO                                                       9999
C
 8710 WRITE (IPR, 9710 ) NZF,LCTPSP
      GO TO                                                       9999
C
 8800 WRITE (IPR, 9800 )
      GO TO                                                       9999
C
C
 9999 KPRTF = -1
C
      RETURN
C
C =================================================================
C                       FORMAT STATEMENTS
C =================================================================
C
 9001 FORMAT(' JGGI =',I5,' JSSO =',I5)
C
 2001 FORMAT(' ISBEG =',I5,/,
     +       ' ISEND =',I5,/,
     +       ' ISINC =',I5,/,
     +       ' ISADV =',I5,/,
     +       ' IFLO  =',I5,/,
     +       ' IFHI  =',I5,/,
     +       ' DZ    =',F10.2,/,
     +       ' IZMAX =',I5,/,
     +       ' IDIP  =',I5,/,
     +       ' IDCLD =',I5,/,
     +       ' IDXSS =',I7,/,
     +       ' LOPR  =',I5,/,
     +       ' MZDIF =',I5,/,
     +       ' NTRNC =',I5)
C
 2002 FORMAT(/,'     LOCSAV =',I5,/,
     +          '     K      =',I5,/,
     +          '     INDX   =',10I5)
C
 2003 FORMAT(' IGBEG  =',I5,/,
     +       ' IGEND  =',I5,/,
     +       ' MG     =',I5,/,
     +       ' LOCSHT =',I5,/,
     +       ' NG     =',I5,/,
     +       ' JDXGG  =',I7,/,
     +       ' MINDX  =',I5,/,
     +       ' MAXDX  =',I5)
C
 2004 FORMAT(2(2X,5I5))
C
 2005 FORMAT(/,' FOCUSING ANALYSIS PARAMETERS',/,
     +         '   ISFBEG  =',I5,/,
     +         '   ISFEND  =',I5,/,
     +         '   ISFINC  =',I5,/,
     +         '   NSFCS   =',I5,/,
     +         '   IZCORR  =',I5,/,
     +         '   DZC     =',F10.2,/,
     +         '   IWAGC   =',I5)
C
 2006 FORMAT(/,' NO FOCUSING ANALYSIS REQUESTED')
C
 2007 FORMAT(/,' NUMH =',I5)
C
 2008 FORMAT(/,' ZDTM,VDTM =',2E12.5)
C
 2009 FORMAT(/,' NZ =',I5)
C
 2010 FORMAT(/,' JSADV,JSINC,JSSO,JDXSS =',3I5,I7)
C
C9000 FORMAT(/,' *** CRAY SYSTEM ONLY ')
 9000 FORMAT(/,' *** WARNING ***  ',
     *       /,' *** WARNING ***  PROC RUNS ON THE CRAY SYSTEM ONLY ',
     *       /,' *** WARNING ***  ',/)
C
 9010 FORMAT(/,' *** NO CARD(1) FOUND FOR ',A4,I1)
C
 9020 FORMAT(/,' *** ILLEGAL PROCESSING MODE ***',/,
     +          ' INPUT DATA MUST BE IN SHOTPOINT MODE')
C
 9030 FORMAT(/,' STARTING SHOTPOINT MISSING; IT IS REQUIRED')
C
 9040 FORMAT(/,' ENDING SHOTPOINT MISSING; IT IS REQUIRED')
C
 9060 FORMAT(/,' HIGHEST FREQENCY MISSING; IT IS REQUIRED')
C
 9070 FORMAT(/,' LOWEST FREQENCY MISSING; IT IS REQUIRED')
C
 9080 FORMAT(/,' Z (DEPTH) STEP SIZE MISSING; IT IS REQUIRED')
C
 9090 FORMAT(/,' *** ERROR ***   NZ,ZDTM,IZMAX =',I5,E12.5,I7)
C
 9091 FORMAT(/,' *** ERROR ***   NZ > NS; NZ,NS =',2I5)
C
 9095 FORMAT(/,' MAXIMUM TRUE DIP MISSING; IT IS REQUIRED')
C
 9096 FORMAT(/,' NUMERICAL ID. MISSING; IT IS REQUIRED')
C
 9100 FORMAT(/,' GROUP INTERVAL OF LINE CARD MISSING; IT IS REQUIRED')
C
 9110 FORMAT(/,' SHOT SPACING HAS TO BE INTEGER MULTIPLIER',
     +         ' OF RECEIVER SPACING',' JDXSS,JDXGG =',2I8)
C
 9120 FORMAT(/,' *** JGGI (RECEIVER PROCESSING DENSITY)',
     +         ' HAS TO BE BETWEEN 1 AND 3 **')
C
 9130 FORMAT(/,' *** JSSO (TRACE OUTPUT DENSITY/SHOT)',
     +         ' HAS TO BE BETWEEN 1 AND 3 **')
C
 9140 FORMAT(/,' ** NEITHER ISADV NOR ISINC IS AN INTEGER MULTIPLIER',
     +         ' OF JSSO **')
C
 9150 FORMAT(/,' SHOT ADVANCE HAS TO BE INTEGER MULTIPLIER OF G. I.')
C
 9151 FORMAT(/,' ERROR IN ISBEG,ISEND,ISINC =',3I5)
C
 9155 FORMAT(/,' ERROR IN ISFINC;  ISFINC =',I5,'  ISINC =',I5)
C
 9160 FORMAT(/,' MAXIMUM DEPTH CORRECTION MISSING; REQUIRED')
C
 9200 FORMAT(/,' *** NO CARD(2) FOUND FOR ',A4,I1)
C
 9210  FORMAT(/,'  ** RECEIVER SPACING CALCULATED FROM (CLD) CARD',
     +          ' NOT EQUAL TO G.I. OF LINE CARD **',/,
     +          '     LOCSAV =',I5,/,
     +          '     K      =',I5,/,
     +          '     INDX   =',10I5)
C
 9300 FORMAT (1X,A4,I1,5X,A4,3I5,1X,I5,I5,/,4(1X,24I5,/))
C
 9400 FORMAT (//,' *** ',A4,I1,' COMPLETED -- NO ERRORS,',
     *         /,' *** TOTAL NUMBER OF PARAMETER RECORDS = ',I5)
C
 9500 FORMAT (/,' *** ERROR WRITING PARAMETER RECORD ***')
C
 9600 FORMAT (/,' *** NO CARD(4) FOUND FOR ',A4,I1)
C
 9650 FORMAT (/,' *** ZMIN NOT EQUAL TO ZDTM *** ZMIN,ZDTM =',2E12.5)
C
 9700 FORMAT (/,' *** ERROR IN CARD(3) ***')
C
 9710 FORMAT (/,' NZF(',I4,') > LCTPSP(',I4,')')
C
 9800 FORMAT (/,' *** ERROR IN SAVGRID ***')
C
C
      END