C$Procedure DSKXSI (DSK, ray-surface intercept with source information)

      SUBROUTINE DSKXSI ( PRI,    TARGET, NSURF,  SRFLST, ET,
     .                    FIXREF, VERTEX, RAYDIR, MAXD,   MAXI,
     .                    XPT,    HANDLE, DLADSC, DSKDSC, DC,
     .                    IC,     FOUND                        )

C$ Abstract
C
C     Compute a ray-surface intercept using data provided by
C     multiple loaded DSK segments. Return information about
C     the source of the data defining the surface on which the
C     intercept was found: DSK handle, DLA and DSK descriptors,
C     and DSK data type-dependent parameters.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C     DSK
C     FRAMES
C     PCK
C     SPK
C     TIME
C
C$ Keywords
C
C     GEOMETRY
C     INTERCEPT
C     SURFACE
C     TOPOGRAPHY
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'dsk.inc'
      INCLUDE 'dsktol.inc'
      INCLUDE 'dsksrc.inc'
      INCLUDE 'srftrn.inc'
      INCLUDE 'zzctr.inc'

      LOGICAL               PRI
      CHARACTER*(*)         TARGET
      INTEGER               NSURF
      INTEGER               SRFLST ( * )
      DOUBLE PRECISION      ET
      CHARACTER*(*)         FIXREF
      DOUBLE PRECISION      VERTEX ( 3 )
      DOUBLE PRECISION      RAYDIR ( 3 )
      INTEGER               MAXD
      INTEGER               MAXI
      DOUBLE PRECISION      XPT    ( 3 )
      INTEGER               HANDLE
      INTEGER               DLADSC ( * )
      DOUBLE PRECISION      DSKDSC ( * )
      DOUBLE PRECISION      DC     ( * )
      INTEGER               IC     ( * )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     PRI        I   Data prioritization flag.
C     TARGET     I   Target body name.
C     NSURF      I   Number of surface IDs in list.
C     SRFLST     I   Surface ID list.
C     ET         I   Epoch, expressed as seconds past J2000 TDB.
C     FIXREF     I   Name of target body-fixed reference frame.
C     VERTEX     I   Vertex of ray.
C     RAYDIR     I   Direction vector of ray.
C     MAXD       I   Size of DC array.
C     MAXI       I   Size of IC array.
C     XPT        O   Intercept point.
C     HANDLE     O   Handle of segment contributing surface data.
C     DLADSC     O   DLA descriptor of segment.
C     DSKDSC     O   DSK descriptor of segment.
C     DC         O   Double precision component of source info.
C     IC         O   Integer component of source info.
C     FOUND      O   Found flag.
C     DCSIZE     P   Required size of DC array.
C     ICSIZE     P   Required size of IC array.
C
C$ Detailed_Input
C
C     PRI        is a logical flag indicating whether to perform
C                a prioritized or unprioritized DSK segment search.
C                In an unprioritized search, no segment masks another:
C                data from all specified segments are used to
C                define the surface of interest.
C
C                The search is unprioritized if and only if PRI
C                is set to .FALSE. In the N0066 SPICE Toolkit, this
C                is the only allowed value.
C
C
C     TARGET     is the name of the target body on which a surface
C                intercept is sought.
C
C
C     NSURF,
C     SRFLST     are, respectively, a count of surface ID codes in a
C                list and an array containing the list. Only DSK
C                segments for the body designated by TARGET and having
C                surface IDs in this list will be considered in the
C                intercept computation. If the list is empty, all DSK
C                segments for TARGET will be considered.
C
C
C     ET         is the epoch of the intersection computation,
C                expressed as seconds past J2000 TDB. This epoch is
C                used only for DSK segment selection. Segments used in
C                the intercept computation must include ET in their
C                time coverage intervals.
C
C
C     FIXREF     is the name of a body-fixed, body-centered reference
C                frame associated with the target. The input ray vectors
C                are specified in this frame, as is the output intercept
C                point.
C
C                The frame designated by FIXREF must have a fixed
C                orientation relative to the frame of any DSK segment
C                used in the computation.
C
C
C     VERTEX,
C     RAYDIR     are, respectively, the vertex and direction vector of
C                the ray to be used in the intercept computation.
C
C                Both the vertex and ray's direction vector must be
C                represented in the reference frame designated by
C                FIXREF. The vertex is considered to be an offset from
C                the target body.
C
C
C     MAXD,
C     MAXI       are, respectively, the declared sizes of the arrays
C                DC and IC. MAXD must be at least DCSIZE, while
C                MAXI must be at least ICSIZE. See the Parameters
C                section for details.
C
C$ Detailed_Output
C
C
C     XPT        is the intercept of the input ray on the surface
C                specified by the inputs
C
C                   PRI
C                   TARGET
C                   NSURF
C                   SRFLST
C                   ET
C
C                if such an intercept exists. If the ray intersects the
C                surface at multiple points, the one closest to the
C                ray's vertex is selected.
C
C                XPT is defined if and only if FOUND is .TRUE.
C
C                Units are km.
C
C
C     HANDLE,
C     DLADSC,
C     DSKDSK     are, respectively, the DSK file handle, DLA descriptor,
C                and DSK descriptor of the DSK file and segment that
C                contributed the surface data on which the intercept
C                was found.
C
C                These outputs are defined if and only if FOUND is
C                .TRUE.
C
C     DC,
C     IC         are, respectively, double precision and integer arrays
C                that may contain additional information associated
C                with the segment contributing the surface data on
C                which the intercept was found. The information is
C                DSK data type-dependent.
C
C                   For DSK type 2 segments
C
C                      IC(1) is the intercept plate ID.
C                      DC is unused.
C
C                These outputs are defined if and only if FOUND is
C                .TRUE.
C
C                The declared length of DC must be at least DSIZE;
C                the declared length of IC must be at least ISIZE.
C                See the Parameter section for details.
C
C
C     FOUND      is a logical flag that is set to .TRUE. if and only if
C                and intercept was found.
C
C
C$ Parameters
C
C     See the include file
C
C        dsksrc.inc
C
C     for declarations of size parameters
C
C        DCSIZE
C        ICSIZE
C
C     for the output arguments
C
C        DC
C        IC
C
C     See the include files
C
C        dla.inc
C        dskdsc.inc
C
C     for declarations of DLA and DSK descriptor sizes and
C     documentation of the contents of these descriptors.
C
C     See the include file
C
C        dsktol.inc
C
C     for the values of tolerance parameters used by default by the
C     ray-surface intercept algorithm. These are discussed in in the
C     Particulars section below.
C
C$ Exceptions
C
C     1)  If the input prioritization flag PRI is set to .TRUE.,
C         the error SPICE(BADPRIORITYSPEC) is signaled.
C
C     2)  If the input body name TARGET cannot be mapped to an
C         ID code, the error SPICE(IDCODENOTFOUND) is signaled.
C
C     3)  If the input frame name FIXREF cannot be mapped to an
C         ID code, the error SPICE(IDCODENOTFOUND) is signaled.
C
C     4)  If the frame center associated with FIXREF cannot be
C         retrieved, the error SPICE(NOFRAMEINFO) is signaled.
C
C     5)  If the frame center associated with FIXREF is not
C         the target body, the error SPICE(INVALIDFRAME) is signaled.
C
C     6)  If MAXD is less than DCSIZE or MAXI is less than ICSIZE,
C         the error SPICE(ARRAYTOOSMALL) will be signaled.
C
C     7)  If NSURF is less than 0, the error SPICE(INVALIDCOUNT)
C         is signaled.
C
C     8)  Any errors that occur during the intercept computation
C         will be signaled by routines in the call tree of this
C         routine.
C$ Files
C
C     Appropriate kernels must be loaded by the calling program before
C     this routine is called.
C
C     The following data are required:
C
C        - SPK data: ephemeris data for the positions of the centers
C          of DSK reference frames relative to the target body are
C          required if those frames are not centered at the target
C          body center.
C
C          Typically ephemeris data are made available by loading one
C          or more SPK files via FURNSH.
C
C        - DSK data: DSK files containing topographic data for the
C          target body must be loaded. If a surface list is specified,
C          data for at least one of the listed surfaces must be loaded.
C
C        - Frame data: if a frame definition is required to convert
C          DSK segment data to the body-fixed frame designated by
C          FIXREF, the target, that definition must be available in the
C          kernel pool. Typically the definitions of frames not already
C          built-in to SPICE are supplied by loading a frame kernel.
C
C        - CK data: if the frame to which FIXREF refers is a CK frame,
C          and if any DSK segments used in the computation have a
C          different frame, at least one CK file will be needed to
C          permit transformation of vectors between that frame and both
C          the J2000 and the target body-fixed frames.
C
C        - SCLK data: if a CK file is needed, an associated SCLK
C          kernel is required to enable conversion between encoded SCLK
C          (used to time-tag CK data) and barycentric dynamical time
C          (TDB).
C
C     In all cases, kernel data are normally loaded once per program
C     run, NOT every time this routine is called.
C
C
C$ Particulars
C
C
C     This is the lowest-level public interface for computing
C     ray-surface intercepts, where the surface is modeled using
C     topographic data provided by DSK files. The highest-level
C     interface for this purpose is SINCPT.
C
C     In cases where the data source information returned by this
C     routine are not needed, the routine DSKXV may be more suitable.
C
C     This routine works with multiple DSK files. It places no
C     restrictions on the data types or coordinate systems of the DSK
C     segments used in the computation. DSK segments using different
C     reference frames may be used in a single computation. The only
C     restriction is that any pair of reference frames used directly or
C     indirectly are related by a constant rotation.
C
C     This routine enables calling applications to identify the source
C     of the data defining the surface on which an intercept was found.
C     The file, segment, and segment-specific information such as a DSK
C     type 2 plate ID are returned.
C
C     This routine can be used for improved efficiency in situations
C     in which multiple ray-surface intercepts are to be performed
C     using a constant ray vertex.
C
C
C     Using DSK data
C     ==============
C
C        DSK loading and unloading
C        -------------------------
C
C        DSK files providing data used by this routine are loaded by
C        calling FURNSH and can be unloaded by calling UNLOAD or
C        KCLEAR. See the documentation of FURNSH for limits on numbers
C        of loaded DSK files.
C
C        For run-time efficiency, it's desirable to avoid frequent
C        loading and unloading of DSK files. When there is a reason to
C        use multiple versions of data for a given target body---for
C        example, if topographic data at varying resolutions are to be
C        used---the surface list can be used to select DSK data to be
C        used for a given computation. It is not necessary to unload
C        the data that are not to be used. This recommendation presumes
C        that DSKs containing different versions of surface data for a
C        given body have different surface ID codes.
C
C
C        DSK data priority
C        -----------------
C
C        A DSK coverage overlap occurs when two segments in loaded DSK
C        files cover part or all of the same domain---for example, a
C        given longitude-latitude rectangle---and when the time
C        intervals of the segments overlap as well.
C
C        When DSK data selection is prioritized, in case of a coverage
C        overlap, if the two competing segments are in different DSK
C        files, the segment in the DSK file loaded last takes
C        precedence. If the two segments are in the same file, the
C        segment located closer to the end of the file takes
C        precedence.
C
C        When DSK data selection is unprioritized, data from competing
C        segments are combined. For example, if two competing segments
C        both represent a surface as sets of triangular plates, the
C        union of those sets of plates is considered to represent the
C        surface.
C
C        Currently only unprioritized data selection is supported.
C        Because prioritized data selection may be the default behavior
C        in a later version of the routine, the presence of the PRI
C        argument is required.
C
C
C        Round-off errors and mitigating algorithms
C        ------------------------------------------
C
C        When topographic data are used to represent the surface of a
C        target body, round-off errors can produce some results that
C        may seem surprising.
C
C        Note that, since the surface in question might have mountains,
C        valleys, and cliffs, the points of intersection found for
C        nearly identical sets of inputs may be quite far apart from
C        each other: for example, a ray that hits a mountain side in a
C        nearly tangent fashion may, on a different host computer, be
C        found to miss the mountain and hit a valley floor much farther
C        from the observer, or even miss the target altogether.
C
C        Round-off errors can affect segment selection: for example, a
C        ray that is expected to intersect the target body's surface
C        near the boundary between two segments might hit either
C        segment, or neither of them; the result may be
C        platform-dependent.
C
C        A similar situation exists when a surface is modeled by a set
C        of triangular plates, and the ray is expected to intersect the
C        surface near a plate boundary.
C
C        To avoid having the routine fail to find an intersection when
C        one clearly should exist, this routine uses two "greedy"
C        algorithms:
C
C           1) If the ray passes sufficiently close to any of the
C              boundary surfaces of a segment (for example, surfaces of
C              maximum and minimum longitude or latitude), that segment
C              is tested for an intersection of the ray with the
C              surface represented by the segment's data.
C
C              This choice prevents all of the segments from being
C              missed when at least one should be hit, but it could, on
C              rare occasions, cause an intersection to be found in a
C              segment other than the one that would be found if higher
C              precision arithmetic were used.
C
C           2) For type 2 segments, which represent surfaces as
C              sets of triangular plates, each plate is expanded very
C              slightly before a ray-plate intersection test is
C              performed. The default plate expansion factor is
C
C                 1 + XFRACT
C
C              where XFRACT is declared in
C
C                 dsktol.inc
C
C              For example, given a value for XFRACT of 1.e-10, the
C              sides of the plate are lengthened by 1/10 of a micron
C              per km. The expansion keeps the centroid of the plate
C              fixed.
C
C              Plate expansion prevents all plates from being missed
C              in cases where clearly at least one should be hit.
C
C              As with the greedy segment selection algorithm, plate
C              expansion can occasionally cause an intercept to be
C              found on a different plate than would be found if higher
C              precision arithmetic were used. It also can occasionally
C              cause an intersection to be found when the ray misses
C              the target by a very small distance.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1)  Compute surface intercepts of rays emanating from a set of
C         vertices distributed on a longitude-latitude grid. All
C         vertices are outside the target body, and all rays point
C         toward the target's center.
C
C         Check intercepts against expected values. Indicate the
C         number of errors, the number of computations, and the
C         number of intercepts found.
C
C        Use the meta-kernel below to load example SPICE kernels.
C
C
C           KPL/MK
C
C           File: dskxsi_ex1.tm
C
C           This meta-kernel is intended to support operation of SPICE
C           example programs. The kernels shown here should not be
C           assumed to contain adequate or correct versions of data
C           required by SPICE-based user applications.
C
C           In order for an application to use this meta-kernel, the
C           kernels referenced here must be present in the user's
C           current working directory.
C
C           The names and contents of the kernels referenced
C           by this meta-kernel are as follows:
C
C              File name                        Contents
C              ---------                        --------
C              phobos512.bds                    DSK based on
C                                               Gaskell ICQ Q=512
C                                               plate model
C           \begindata
C
C              PATH_SYMBOLS    = 'GEN'
C              PATH_VALUES     = '/ftp/pub/naif/generic_kernels'
C
C              KERNELS_TO_LOAD = ( '$GEN/dsk/phobos/phobos512.bds' )
C
C           \begintext
C
C
C     Example code begins here.
C
C
C              PROGRAM SPEAR
C              IMPLICIT NONE
C        C
C        C     Multi-segment spear program.
C        C
C        C     This program expects all loaded DSKs
C        C     to represent the same body and surface.
C        C
C        C        Syntax: spear <meta-kernel>
C        C
C        C
C              INCLUDE 'dla.inc'
C              INCLUDE 'dsk.inc'
C              INCLUDE 'dskdsc.inc'
C              INCLUDE 'dsksrc.inc'
C              INCLUDE 'srftrn.inc'
C        C
C        C     SPICELIB functions
C        C
C              DOUBLE PRECISION      RPD
C              DOUBLE PRECISION      VDIST
C
C              LOGICAL               FAILED
C        C
C        C     Local parameters
C        C
C              DOUBLE PRECISION      DTOL
C              PARAMETER           ( DTOL   = 1.D-14 )
C
C              INTEGER               BDNMLN
C              PARAMETER           ( BDNMLN = 36 )
C
C              INTEGER               FILSIZ
C              PARAMETER           ( FILSIZ = 255 )
C
C              INTEGER               FRNMLN
C              PARAMETER           ( FRNMLN = 32 )
C
C              INTEGER               TYPLEN
C              PARAMETER           ( TYPLEN = 4 )
C
C        C
C        C     Local variables
C        C
C              CHARACTER*(FILSIZ)    DSK1
C              CHARACTER*(TYPLEN)    FILTYP
C              CHARACTER*(FRNMLN)    FIXREF
C              CHARACTER*(FILSIZ)    META
C              CHARACTER*(FILSIZ)    SOURCE
C              CHARACTER*(BDNMLN)    TARGET
C
C              DOUBLE PRECISION      D
C              DOUBLE PRECISION      DC     ( DCSIZE )
C              DOUBLE PRECISION      DSKDSC ( DSKDSZ )
C              DOUBLE PRECISION      ET
C              DOUBLE PRECISION      RAYDIR ( 3 )
C              DOUBLE PRECISION      LAT
C              DOUBLE PRECISION      LATCRD ( 3 )
C              DOUBLE PRECISION      LATSTP
C              DOUBLE PRECISION      LON
C              DOUBLE PRECISION      LONSTP
C              DOUBLE PRECISION      POLMRG
C              DOUBLE PRECISION      R
C              DOUBLE PRECISION      RADIUS
C              DOUBLE PRECISION      VERTEX ( 3 )
C              DOUBLE PRECISION      XPT    ( 3 )
C              DOUBLE PRECISION      XYZHIT ( 3 )
C
C              INTEGER               BODYID
C              INTEGER               DLADSC ( DLADSZ )
C              INTEGER               DTYPE
C              INTEGER               FRAMID
C              INTEGER               HANDLE
C              INTEGER               IC     ( ICSIZE )
C              INTEGER               NCASES
C              INTEGER               NDERR
C              INTEGER               NHITS
C              INTEGER               NLSTEP
C              INTEGER               NSURF
C              INTEGER               PLID
C              INTEGER               SRFLST ( MAXSRF )
C              INTEGER               SURFID
C
C              LOGICAL               FOUND
C
C
C              CALL CHKIN ( 'SPEAR' )
C        C
C        C     Load kernel.
C        C
C              CALL GETCML ( META )
C
C              IF ( META .EQ. ' ' ) THEN
C                 CALL TOSTDO( 'Syntax: spear <meta-kernel>' )
C                 CALL BYEBYE( 'SUCCESS' )
C              END IF
C        C
C        C     Load kernels.
C        C
C              CALL FURNSH ( META )
C        C
C        C     Get a handle for one of the loaded DSKs,
C        C     then find the first segment and extract
C        C     the body and surface IDs.
C        C
C              CALL KDATA  ( 1,      'DSK',  DSK1, FILTYP,
C             .              SOURCE, HANDLE, FOUND )
C
C              CALL DLABFS ( HANDLE, DLADSC, FOUND )
C
C              IF ( .NOT. FOUND ) THEN
C                 CALL SIGERR ( 'SPICE(NOSEGMENT)' )
C              END IF
C
C              CALL DSKGD ( HANDLE, DLADSC, DSKDSC )
C
C              BODYID = NINT( DSKDSC(CTRIDX) )
C              SURFID = NINT( DSKDSC(SRFIDX) )
C              FRAMID = NINT( DSKDSC(FRMIDX) )
C
C              CALL BODC2N ( BODYID, TARGET, FOUND )
C
C              IF ( .NOT. FOUND ) THEN
C                 CALL SETMSG ( 'Cannot map body ID # to a name.' )
C                 CALL ERRINT ( '#',  BODYID                      )
C                 CALL SIGERR ( 'SPICE(BODYNAMENOTFOUND)'         )
C              END IF
C
C              CALL FRMNAM ( FRAMID, FIXREF )
C
C              IF ( FIXREF .EQ. ' ' ) THEN
C                 CALL SETMSG ( 'Cannot map frame ID # to a name.' )
C                 CALL ERRINT ( '#',  FRAMID                       )
C                 CALL SIGERR ( 'SPICE(FRAMENAMENOTFOUND)'         )
C              END IF
C
C        C
C        C     Set the magnitude of the ray vertices. Use a large
C        C     number to ensure the vertices are outside of
C        C     any realistic target.
C        C
C              R = 1.D10
C
C        C
C        C     Spear the target with rays pointing toward
C        C     the origin.  Use a grid of ray vertices
C        C     located on a sphere enclosing the target.
C        C
C        C     The variable POLMRG ("pole margin") can
C        C     be set to a small positive value to reduce
C        C     the number of intercepts done at the poles.
C        C     This may speed up the computation for
C        C     the multi-segment case, since rays parallel
C        C     to the Z axis will cause all segments converging
C        C     at the pole of interest to be tested for an
C        C     intersection.
C        C
C              POLMRG = 5.D-1
C              LATSTP = 1.D0
C              LONSTP = 2.D0
C
C              NCASES = 0
C              NHITS  = 0
C              NDERR  = 0
C
C              LON    = -180.D0
C              LAT    = 90.D0
C              NLSTEP = 0
C
C
C              WRITE (*,*) 'Computing intercepts...'
C
C              DO WHILE ( LON .LT. 180.D0 )
C
C                 DO WHILE ( NLSTEP .LE. 180  )
C
C                    IF ( LON .EQ. -180.D0 ) THEN
C
C                       LAT = 90.D0 - NLSTEP*LATSTP
C
C                    ELSE
C
C                       IF ( NLSTEP .EQ. 0 ) THEN
C
C                          LAT =  90.D0 - POLMRG
C
C                       ELSE IF ( NLSTEP .EQ. 180 ) THEN
C
C                          LAT = -90.D0 + POLMRG
C
C                       ELSE
C
C                          LAT = 90.D0 - NLSTEP*LATSTP
C
C                       END IF
C
C                    END IF
C
C                    NCASES = NCASES + 1
C
C                    CALL LATREC ( R, LON*RPD(), LAT*RPD(), VERTEX )
C                    CALL VMINUS ( VERTEX, RAYDIR )
C
C                    NSURF     = 1
C                    SRFLST(1) = SURFID
C
C                    CALL DSKXSI ( .FALSE., TARGET, NSURF,  SRFLST,
C             .                    ET,      FIXREF, VERTEX, RAYDIR,
C             .                    DCSIZE,  ICSIZE, XPT,    HANDLE,
C             .                    DLADSC, DSKDSC,  DC,     IC,
C             .                    FOUND                           )
C
C                    IF ( .NOT. FAILED() .AND. FOUND ) THEN
C        C
C        C              Record that a new intercept was found.
C        C
C                       NHITS = NHITS + 1
C        C
C        C              Compute the latitude and longitude of
C        C              the intercept. Make sure these agree
C        C              well with those of the vertex.
C        C
C                       CALL RECLAT ( XPT,       LATCRD(1),
C             .                       LATCRD(2), LATCRD(3) )
C
C                       RADIUS = LATCRD(1)
C
C                       CALL LATREC ( RADIUS,   LON*RPD(),
C             .                       LAT*RPD(), XYZHIT    )
C
C                       D = VDIST ( XPT, XYZHIT )
C
C                       IF ( D/R .GT. DTOL ) THEN
C        C
C        C                 Get the intercept segment's plate ID if
C        C                 applicable.
C        C
C                          DTYPE = NINT( DSKDSC(TYPIDX) )
C
C                          WRITE (*,*) '======================'
C                          WRITE (*,*) 'LON, LAT       = ', LON, LAT
C                          WRITE (*,*) 'Bad intercept'
C                          WRITE (*,*) 'Distance error = ', D
C                          WRITE (*,*) 'XPT            = ', XPT
C                          WRITE (*,*) 'XYZHIT         = ', XYZHIT
C
C                          IF ( DTYPE .EQ. 2 ) THEN
C                             PLID = IC(1)
C                             WRITE (*,*) 'Plate ID      = ', PLID
C                          END IF
C
C                          NDERR = NDERR + 1
C
C                       END IF
C
C                    ELSE
C        C
C        C              Missing the target entirely is a fatal error.
C        C
C                       WRITE (*,*) '======================'
C                       WRITE (*,*) 'LON, LAT = ', LON, LAT
C                       WRITE (*,*) 'No intercept'
C                       WRITE (*,*) 'NCASES = ', NCASES
C                       STOP
C
C                    END IF
C
C                    NLSTEP = NLSTEP + 1
C
C                 END DO
C
C                 LON    = LON + LONSTP
C                 LAT    = 90.D0
C                 NLSTEP = 0
C
C              END DO
C
C              WRITE (*,*) 'Done.'
C              WRITE (*,*) ' '
C              WRITE (*,*) 'NCASES = ', NCASES
C              WRITE (*,*) 'NHITS  = ', NHITS
C              WRITE (*,*) 'NDERR  = ', NDERR
C              WRITE (*,*) ' '
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran 64-bit
C     platform, the output was:
C
C
C        Computing intercepts...
C        Done.
C
C        NCASES =        32580
C        NHITS  =        32580
C        NDERR  =            0
C
C
C$ Restrictions
C
C     1)  The frame designated by FIXREF must have a fixed
C         orientation relative to the frame of any DSK segment
C         used in the computation. This routine has no
C         practical way of ensuring that this condition is met;
C         so this responsibility is delegated to the calling
C         application.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 04-APR-2017 (NJB)
C
C        Original 26-FEB-2016 (NJB)
C
C
C-&

C$ Index_Entries
C
C     dsk ray-surface intercept with source information
C     dsk ray-surface intercept with handle and descriptors
C     dsk ray-surface intercept with handle and descriptors
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               BDNMLN
      PARAMETER           ( BDNMLN = 36 )

      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN = 32 )

C
C     Local variables
C
      CHARACTER*(FRNMLN)    PRVFRM
      CHARACTER*(BDNMLN)    SVTNAM

      INTEGER               FIXFID
      INTEGER               FRMCTR ( CTRSIZ )
      INTEGER               FXCENT
      INTEGER               FXCLSS
      INTEGER               FXTPID
      INTEGER               PRVTCD
      INTEGER               SVTCDE
      INTEGER               TRGCDE
      INTEGER               TRGCTR ( CTRSIZ )

      LOGICAL               FIRST
      LOGICAL               FRMFND
      LOGICAL               NEWFRM
      LOGICAL               NEWTRG
      LOGICAL               SVTFND
      LOGICAL               TRGFND
      LOGICAL               UPDATE

C
C     Saved variables
C
      SAVE                  FIRST
      SAVE                  FIXFID
      SAVE                  FRMCTR
      SAVE                  PRVFRM
      SAVE                  PRVTCD
      SAVE                  SVTCDE
      SAVE                  SVTFND
      SAVE                  SVTNAM
      SAVE                  TRGCDE
      SAVE                  TRGCTR
C
C     Initial values
C
      DATA                  FIRST  / .TRUE. /
      DATA                  PRVFRM / ' '    /
      DATA                  PRVTCD / 0      /

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'DSKXSI' )

      IF ( FIRST ) THEN
C
C        Initialize counters.
C
         CALL ZZCTRUIN( TRGCTR )
         CALL ZZCTRUIN( FRMCTR )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'DSKXSI' )
            RETURN
         END IF

      END IF

C
C     Reject PRI if not set properly.
C
      IF ( PRI ) THEN

         CALL SETMSG ( 'In the N0066 SPICE Toolkit, PRI must be '
     .   //            'set to .FALSE., indicating that an '
     .   //            'unprioritized search is to be performed.' )
         CALL SIGERR ( 'SPICE(BADPRIORITYSPEC)'                   )
         CALL CHKOUT ( 'DSKXSI'                                   )
         RETURN

      END IF

C
C     Reject NSURF if not set properly. Zero is a valid value.
C
      IF ( NSURF .LT. 0 ) THEN

         CALL SETMSG ( 'The surface count NSURF must be non-negative '
     .   //            'but was #.'                                   )
         CALL ERRINT ( '#',  NSURF                                    )
         CALL SIGERR ( 'SPICE(INVALIDCOUNT)'                          )
         CALL CHKOUT ( 'DSKXSI'                                       )
         RETURN

      END IF

C
C     Check output array sizes.
C
      IF (  ( MAXD .LT. DCSIZE ) .OR. ( MAXI .LT. ICSIZE )  ) THEN

         CALL SETMSG ( 'Output array size MAXD must be at least #; '
     .   //            'output array size MAXI must be at least #. '
     .   //            'Actual sizes were # and # respectively.'    )
         CALL ERRINT ( '#',  DCSIZE                                 )
         CALL ERRINT ( '#',  ICSIZE                                 )
         CALL ERRINT ( '#',  MAXD                                   )
         CALL ERRINT ( '#',  MAXI                                   )
         CALL SIGERR ( 'SPICE(ARRAYTOOSMALL)'                       )
         CALL CHKOUT ( 'DSKXSI'                                     )
         RETURN

      END IF

C
C     Obtain integer codes for the target and reference frame.
C
      CALL ZZBODS2C ( TRGCTR, SVTNAM, SVTCDE, SVTFND,
     .                TARGET, TRGCDE, TRGFND         )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'DSKXSI' )
         RETURN
      END IF

      IF ( .NOT. TRGFND ) THEN

         CALL SETMSG ( 'The target, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit, or that you '
     .   //            'failed to load a kernel containing a '
     .   //            'name-ID mapping for this body.'           )
         CALL ERRCH  ( '#', TARGET                                )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'DSKXSI'                                   )
         RETURN

      END IF

      NEWFRM = ( FIXREF .NE. PRVFRM ) .OR. FIRST
      NEWTRG = ( TRGCDE .NE. PRVTCD ) .OR. FIRST

C
C     Get the frame ID if the pool state has changed. The
C     first call to ZZPCKTRCK will indicate an update.
C
      CALL ZZPCTRCK ( FRMCTR, UPDATE )

      IF ( UPDATE .OR. NEWFRM .OR. NEWTRG ) THEN

         CALL NAMFRM ( FIXREF, FIXFID )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'DSKXSI' )
            RETURN
         END IF

         IF ( FIXFID .EQ. 0 ) THEN

            CALL SETMSG ( 'Reference frame # is not recognized by '
     .      //            'the SPICE frame subsystem. Possibly '
     .      //            'a required frame definition kernel has '
     .      //            'not been loaded.'                        )
            CALL ERRCH  ( '#',  FIXREF                              )
            CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                   )
            CALL CHKOUT ( 'DSKXSI'                                  )
            RETURN

         END IF

C
C        Determine the attributes of the frame designated by FIXREF.
C
         CALL FRINFO ( FIXFID, FXCENT, FXCLSS, FXTPID, FRMFND )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'DSKXSI' )
            RETURN
         END IF

         IF ( .NOT. FRMFND ) THEN

            CALL SETMSG ( 'Attributes for reference frame # '
     .      //            'could not be obtained from '
     .      //            'the SPICE frame subsystem. Possibly '
     .      //            'a required frame definition kernel has '
     .      //            'not been loaded.'                        )
            CALL ERRCH  ( '#',  FIXREF                              )
            CALL SIGERR ( 'SPICE(NOFRAMEINFO)'                      )
            CALL CHKOUT ( 'DSKXSI'                                  )
            RETURN

         END IF
C
C        Make sure that FIXREF is centered at the target body's center.
C
         IF ( FXCENT .NE. TRGCDE ) THEN

            CALL SETMSG ( 'Reference frame # is not centered at the '
     .      //            'target body #. The ID code of the frame '
     .      //            'center is #.'                             )
            CALL ERRCH  ( '#',  FIXREF                               )
            CALL ERRCH  ( '#',  TARGET                               )
            CALL ERRINT ( '#',  FXCENT                               )
            CALL SIGERR ( 'SPICE(INVALIDFRAME)'                      )
            CALL CHKOUT ( 'DSKXSI'                                   )
            RETURN

         END IF

C
C        We have a valid frame at this point. Save the name.
C
         FIRST  = .FALSE.
         PRVFRM = FIXREF

C
C        Update the previous target ID code as well.
C
         PRVTCD = TRGCDE

      END IF

C
C     TRGCDE and FIXFID are set.
C
C
C     Perform the intercept computation.
C
      CALL ZZSBFXRI ( TRGCDE, NSURF,  SRFLST, ET,
     .                FIXFID, VERTEX, RAYDIR, XPT, HANDLE,
     .                DLADSC, DSKDSC, DC,     IC,  FOUND   )

      CALL CHKOUT ( 'DSKXSI' )
      RETURN
      END


CSTA1A
C           SUBROUTINE STA1A
      SUBROUTINE STA1A
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1 K,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
      REAL MR1A
      COMMON /SSTA1A/VU1A(6,8),WG1A(6,8),WGT1A(8),VZ1A(6,8),  CP1A(8),
     1PS1A(6,8),RU1A(6,8),R1A(6,8),BET1A(6,8),RI(6,8),TTR1A(6,8),PTR1A(6
     2,8),MR1A(6,8)
      COMMON/RPMCOM/RPMK(8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      COMMON/TPT1/PT1(6),TT1(6,8)
      COMMON /TDIL/TWG (6,8),pwg(6,8)
      COMMON/T1A/TT1A(6,8)
C        DETERMINE FLOW CONDITIONS RELATIVE TO ROTOR,  FIND INCIDENCE
C         ANGLE RECOVERY ROTOR INLET STATIONS,  OBTAIN GAS PROPERTIES,
C         ABSOLUTE TANGENTIAL COMPONENT VELOCITY ADJUSTED FOR DIAMETER
C         CHANGE TO CONSERVE ANGULAR MOMENTUM,  AXIAL COMPONENT
C         VELOCITY ADJUSTED FOR WEIGHT FLOW, AREA,, AND DENSITY CHANGE
C         FROM STA  1.
C
C
      TWGF=0.
      IF(TWG(3,K).GT.0.) TWGF=1.
      I=IP
      ID=-1
      TS1A     =TS1(I,K)
C        RATIO OF FLOW CHANGE
      WR=RWG(3,K)/RWG(2,K)
C        TOTAL STATION FLOW
      WGT1A(K)=WR*WGT1(K)
C        ADJUST TANGENTIAL VELOCITY
13    VU1A(I,K)=VU1(I,K)*DP1(I,K)/DP1A(I,K)
      TT1A(I,K)=TT1(I,K)
      if (twgf.gt.0.0) then
        ttm=(tt1(i,k)+(wr-1.)*twg(3,k))/wr
        tpp=(ttm+tt1(i,k))/2.
        tpc=(ttm+twg(3,k))/2.
        call cpa(pt0(i,k),tpc,0.0,0.0,cpc)
        call gama(pt0(i,k),tpp,fairx(2,k),wairx(2,k),gamtpp)
        extpp=gamtpp/(gamtpp-1.)
        cpp=rg1(k)*extpp/aj
        tt1a(i,k)=(cpp*tt1(i,k)+(wr-1.)*cpc*twg(3,k))/(cpp+(wr-1.)*cpc)
      end if
C        ADJUST FLOW
      WG1A(I,K)=WR*WG1(I,K)
      RHOSTR=RHOS1(I,K)
C        ADJUST AXIAL VELOCITY
1     VZ1A(I,K)=WR*VZ1(I,K)*ANN1(I,K)*RHOS1(I,K)/(ANN1A(I,K)
     1*RHOSTR)
      V1A     =SQRT(VU1A(I,K)*VU1A(I,K)+VZ1A(I,K)*VZ1A(I,K))
C     IF(I-IP)2,3,2
C     replaced by
      IF(I.NE.IP) THEN
         GO TO 2
      ELSE
         GO TO 3
      ENDIF
2     EX=(GAM(3,K)-1.)/GAM(3,K)
      EXI=1./EX
      GO TO 4
C3     IF(GAMF)12,12,2
C     replaced by
3     IF(GAMF.LE.0.) THEN
         GO TO 12
      ELSE
         GO TO 2
      ENDIF
12    TA1A=.5*(TT1A(I,K)+TS1A)
      CALL GAMA(PT0(I,K),TA1A   ,FAIRx(3,k),WAIRx(3,k),GAM(3,K))
      EX=(GAM(3,K)-1.)/GAM(3,K)
      EXI=1./EX
4     CP1A(K)=rg1a(k)*EXI/AJ
      DELTS=(V1(I,K)*V1(I,K)-V1A     *V1A     )/(2.*G*AJ*CP1A(K))
      TS1A=TS1(I,K)+DELTS+TT1A(I,K)-TT1(I,K)
      PS1A(I,K)=PS1(I,K)*(TT1(I,K)*TS1A/TT1A(I,K)/TS1(I,K))**EXI
      RHOS1A     =144.*PS1A(I,K)/(rg1a(k)*TS1A     )
C        DENSITY ERROR
      RHOE=(RHOS1A     -RHOSTR)/RHOS1A
C     IF (ABS(RHOE)-RHOTOL)6,6,5
C     replaced by ...............
      IF((ABS(RHOE)-RHOTOL).LE.0.) THEN
         GO TO 6
      ELSE
         GO TO 5
      ENDIF
5     RHOSTR=RHOS1A
      GO TO 1
6     RU1A(I,K)=VU1A(I,K)-U1A(I,K)
      R1A(I,K)=SQRT(RU1A(I,K)*RU1A(I,K)+VZ1A(I,K)*VZ1A(I,K))
      SBET1A     =RU1A(I,K)/R1A(I,K)
      BET1A(I,K)=ATAN2(SBET1A     ,SQRT(1.-SBET1A     *SBET1A     ))
      IF(RVU1(I,K).NE.0.) RADRD(I,K)=BET1A(I,K)
C     IF(OMEGAR(I,K))8,8,7
C     replaced by ...............
      IF(OMEGAR(I,K).LE.0.) THEN
         GO TO 8
      ELSE
         GO TO 7
      ENDIF
7     ETARR(I,K)=1.
      EXPRE=0.0
8     MR1A(I,K)=R1A(I,K)/SQRT(GAM(3,K)*G*rg1a(k)*TS1A     )
      TRTS1A     =1.+(GAM(3,K)-1.)*MR1A(I,K)*MR1A(I,K)/2.
      IF(TRTS1A.GT.1.) GO TO 32
      PREVER = .TRUE.
      GO TO 17
32    TTR1A(I,K)=TS1A     *TRTS1A
      RI(I,K)=BET1A(I,K)-RADRD(I,K)
      IF(RI(I,K).GT.1.5707) RI(I,K)=1.5707
      IF(RI(I,K).LT.(-1.5707)) RI(I,K)=(-1.5707)
C     IF(RI(I,K))9,9,10
C     replaced by ...............
      IF(RI(I,K).LE.0.) THEN
         GO TO 9
      ELSE
         GO TO 10
      ENDIF
9     EXPR=EXPN
      GO TO 11
10    EXPR=EXPP
11    PRPS1A     =(1.+(TRTS1A     -1.)*ETARR(I,K)*(COS(RI(I,K))**
     1EXPR))**EXI
      PTR1A(I,K)=PS1A(I,K)*PRPS1A
C     IF (ISECT-I)14,16,14
C     replaced by ...............
      IF((ISECT-I).NE.0) THEN
         GO TO 14
      ELSE
         GO TO 16
      ENDIF
14    I=I+ID
C     IF (I)15,15,13
C     replaced by ...............
      IF(I.LE.0) THEN
         GO TO 15
      ELSE
         GO TO 13
      ENDIF
15    ID=1
      I=IP+ID
      GO TO 13
16    CONTINUE
      j=2
      GO TO (17,18),J
17    CALL DIAGT(3)
18    RETURN
      END


C$Procedure CKGR06 ( C-kernel, get record, type 06 )

      SUBROUTINE CKGR06 ( HANDLE, DESCR, MSNO, RECNO, RECORD )
      IMPLICIT NONE

C$ Abstract
C
C     Given the handle and descriptor of a type 6 segment in a CK file,
C     return a specified pointing record from that segment.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C     DAF
C
C$ Keywords
C
C     POINTING
C
C$ Declarations

      INCLUDE 'ck06.inc'

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR  ( * )
      INTEGER               MSNO
      INTEGER               RECNO
      DOUBLE PRECISION      RECORD ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   The handle of the file containing the segment.
C     DESCR      I   The segment descriptor.
C     MSNO       I   Index of the mini-segment containing the record.
C     RECNO      I   Index of the pointing record to be returned.
C     RECORD     O   The pointing record.
C
C$ Detailed_Input
C
C     HANDLE     is the handle of the binary CK file containing the
C                segment. Normally the CK file should be open for read
C                access. See the Files section below for details.
C
C     DESCR      is the DAF descriptor of the type 6 segment.
C
C     RECNO      is the number of the discrete pointing instance to be
C                returned from the specified type 6 segment.
C
C$ Detailed_Output
C
C     RECORD     is the pointing record indexed by RECNO in the
C                segment. The contents are as follows:
C
C                   RECORD( 1 ) = CLKOUT
C
C                CLKOUT is the encoded spacecraft clock time associated
C                with the returned pointing values.
C
C                   RECORD( 2 ) = SUBTYP
C
C                SUBTYP is the CK type 6 subtype code. This code
C                identifies the structure and meaning of the rest
C                of the record. However, all subtypes have a
C                quaternion stored in elements 4-7.
C
C                   RECORD( 3 ) = RATE
C
C                RATE is the nominal SCLK rate expressed in units of
C                seconds per tick. This rate is required to convert
C                quaternion or angular velocity derivatives from units
C                of radians/tick to radians/s.
C
C                   RECORD( 4 ) = q0
C                   RECORD( 5 ) = q1
C                   RECORD( 6 ) = q2
C                   RECORD( 7 ) = q3
C
C                Subtype 1 ends here; there are no angular velocity
C                data. Angular velocity is derived by differentiating
C                Lagrange interpolating polynomials.
C
C                   RECORD(  8 ) =  ]
C                   RECORD(  9 ) =  ] --- For subtypes 0 and 2, these
C                   RECORD( 10 ) =  ]     elements contain a quaternion
C                   RECORD( 11 ) =  ]     derivative. For subtype 3,
C                                         elements 8-10 contain an
C                                         angular velocity vector;
C                                         element 11 is unassigned.
C
C                                         All subtypes except subtype
C                                         2 stop here.
C
C                   RECORD( 12 ) =  ]
C                   RECORD( 13 ) =  ] --- For subtype 2, these
C                   RECORD( 14 ) =  ]     elements contain an angular
C                                         velocity vector.
C
C
C                   RECORD( 15 ) =  ]
C                   RECORD( 16 ) =  ] --- For subtype 2, these
C                   RECORD( 17 ) =  ]     elements contain the
C                                         derivative of an angular
C                                         velocity vector.
C
C                The quantities q0 - q3 are the components of the
C                quaternion that represents the C-matrix that transforms
C                vectors from the inertial reference frame of the
C                segment to the instrument frame at time CLKOUT.
C
C                Quaternion derivatives, angular velocity, or the
C                derivative of angular velocity are valid only if
C                these are supported by the segment subtype and
C                if the segment descriptor indicates that angular
C                velocity is present.
C
C                The components of the angular velocity vector are
C                specified relative to the inertial reference frame of
C                the segment.
C
C                Units of angular velocity and of quaternion
C                derivatives are radians/second and 1/second
C                respectively.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the segment is not of data type 6, the error
C         SPICE(CKWRONGDATATYPE) is signaled.
C
C     2)  If MSNO is less than one or greater than the number of
C         mini-segments in the specified segment, the error
C         SPICE(INDEXOUTOFRANGE) is signaled.
C
C     3)  If RECNO is less than one or greater than the number of
C         records in the specified segment, the error
C         SPICE(CKNONEXISTREC) is signaled.
C
C     4)  If the specified handle does not belong to any DAF file that
C         is currently known to be open, an error is diagnosed by a
C         routine in the call tree of this routine.
C
C     5)  If DESCR is not a valid descriptor of a valid segment in the
C         CK file specified by HANDLE, the results of this routine are
C         unpredictable.
C
C     6)  If the segment subtype is not recognized, the error
C         SPICE(NOTSUPPORTED) is signaled.
C
C$ Files
C
C     The CK file specified by HANDLE may be open for read or write
C     access. Normally, the file should have been opened for read
C     access. If the file is open for write access, the calling
C     application must ensure integrity of the CK segment being read.
C     If the structure of the segment is invalid---for example, if the
C     segment has been partially written---this routine will either
C     return invalid results, or it will cause a system-level runtime
C     error.
C
C$ Particulars
C
C     Note that the mini-segment interpolation window size is not
C     returned in the pointing record; this parameter is not required
C     in order to interpret the record. Call CKMP06 to obtain the
C     window size.
C
C     For a complete description of the internal structure of a type 6
C     segment, see the CK Required Reading.
C
C     This routine is normally used in conjunction with CKNM06 and
C     CKGM06 to obtain time tags and packet data from a specified type
C     6 CK segment.
C
C$ Examples
C
C     The numerical results shown for this example may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C
C     1) The following program dumps records from a CK file that
C        contains only type 6 segments.
C
C        Example code begins here.
C
C
C             PROGRAM GREX1
C             IMPLICIT NONE
C       C
C       C     Dump all records from a CK that
C       C     contains only segments of type 6.
C       C
C
C             INCLUDE 'ck06.inc'
C       C
C       C     Local parameters
C       C
C             INTEGER               ND
C             PARAMETER           ( ND     = 2 )
C
C             INTEGER               NI
C             PARAMETER           ( NI     = 6 )
C
C             INTEGER               DSCSIZ
C             PARAMETER           ( DSCSIZ = 5 )
C
C             INTEGER               FILSIZ
C             PARAMETER           ( FILSIZ = 255 )
C
C       C
C       C     RECSIZ is the size of the largest pointing
C       C     record, which corresponds to subtype 2.
C       C
C             INTEGER               RECSIZ
C             PARAMETER           ( RECSIZ = C06PS2 + 3 )
C
C       C
C       C     Local variables
C       C
C             CHARACTER*(FILSIZ)    CK
C
C             DOUBLE PRECISION      DC     ( ND )
C             DOUBLE PRECISION      DESCR  ( DSCSIZ )
C             DOUBLE PRECISION      IVLBDS ( 2 )
C             DOUBLE PRECISION      LSTEPC
C             DOUBLE PRECISION      RATE
C             DOUBLE PRECISION      RECORD ( RECSIZ )
C
C             INTEGER               DTYPE
C             INTEGER               HANDLE
C             INTEGER               IC     ( NI )
C             INTEGER               RECNO
C             INTEGER               MSNO
C             INTEGER               NMINI
C             INTEGER               NREC
C             INTEGER               SEGNO
C             INTEGER               SUBTYP
C             INTEGER               WINSIZ
C
C             LOGICAL               FOUND
C
C
C             CALL PROMPT ( 'Enter name of CK to dump > ', CK )
C
C             CALL DAFOPR ( CK, HANDLE )
C       C
C       C     Dump data from each CK segment.
C       C
C             SEGNO = 0
C
C             CALL DAFBFS ( HANDLE )
C             CALL DAFFNA ( FOUND  )
C
C             DO WHILE ( FOUND )
C
C                SEGNO = SEGNO + 1
C
C                WRITE (*,*) ' '
C                WRITE (*,*) ' '
C                WRITE (*,*) 'Segment number: ', SEGNO
C
C       C
C       C        Fetch and unpack the descriptor of the
C       C        current segment; check the data type.
C       C
C                CALL DAFGS ( DESCR )
C                CALL DAFUS ( DESCR, ND, NI, DC, IC )
C
C                DTYPE = IC(3)
C
C                IF ( DTYPE .NE. 6 ) THEN
C
C                   CALL SETMSG ( 'Data type must be 6 but was #.' )
C                   CALL ERRINT ( '#',  DTYPE                      )
C                   CALL SIGERR ( 'SPICE(NOTSUPPORTED)'            )
C
C                END IF
C       C
C       C        Get the mini-segment count for this
C       C        segment.
C       C
C                CALL CKNM06 ( HANDLE, DESCR, NMINI )
C       C
C       C        Dump data from each mini-segment.
C       C
C                DO MSNO = 1, NMINI
C       C
C       C           Get the mini-segment's record count
C       C           and time bounds.
C       C
C                   CALL CKMP06 ( HANDLE, DESCR, MSNO,   RATE,  SUBTYP,
C            .                    WINSIZ, NREC,  IVLBDS, LSTEPC        )
C
C                   WRITE (*,*) ' '
C                   WRITE (*,*) '   Mini-segment number: ', MSNO
C                   WRITE (*,*) '      Rate:           ',   RATE
C                   WRITE (*,*) '      Subtype:        ',   SUBTYP
C                   WRITE (*,*) '      Window size:    ',   WINSIZ
C                   WRITE (*,*) '      Interval start: ',   IVLBDS(1)
C                   WRITE (*,*) '      Interval stop:  ',   IVLBDS(2)
C                   WRITE (*,*) '      Last epoch:     ',   LSTEPC
C                   WRITE (*,*) ' '
C
C                   DO RECNO = 1, NREC
C
C                      CALL CKGR06 ( HANDLE, DESCR,
C            .                       MSNO,   RECNO,  RECORD )
C
C                      WRITE (*,*) '      Record number: ', RECNO
C                      WRITE (*,*) '         SCLKDP:     ', RECORD(1)
C                      WRITE (*,*) '         Clock rate: ', RECORD(3)
C
C                      IF ( SUBTYP .EQ. C06TP0 ) THEN
C
C                         WRITE (*,*) '         Q(0): ', RECORD(4)
C                         WRITE (*,*) '         Q(1): ', RECORD(5)
C                         WRITE (*,*) '         Q(2): ', RECORD(6)
C                         WRITE (*,*) '         Q(3): ', RECORD(7)
C                         WRITE (*,*) '    d Q(0)/dt: ', RECORD(8)
C                         WRITE (*,*) '    d Q(1)/dt: ', RECORD(9)
C                         WRITE (*,*) '    d Q(2)/dt: ', RECORD(10)
C                         WRITE (*,*) '    d Q(3)/dt: ', RECORD(11)
C
C                      ELSE IF ( SUBTYP .EQ. C06TP1 ) THEN
C
C                         WRITE (*,*) '         Q(0): ', RECORD(4)
C                         WRITE (*,*) '         Q(1): ', RECORD(5)
C                         WRITE (*,*) '         Q(2): ', RECORD(6)
C                         WRITE (*,*) '         Q(3): ', RECORD(7)
C
C                      ELSE IF ( SUBTYP .EQ. C06TP2 ) THEN
C
C                         WRITE (*,*) '         Q(0): ', RECORD(4)
C                         WRITE (*,*) '         Q(1): ', RECORD(5)
C                         WRITE (*,*) '         Q(2): ', RECORD(6)
C                         WRITE (*,*) '         Q(3): ', RECORD(7)
C                         WRITE (*,*) '    d Q(0)/dt: ', RECORD(8)
C                         WRITE (*,*) '    d Q(1)/dt: ', RECORD(9)
C                         WRITE (*,*) '    d Q(2)/dt: ', RECORD(10)
C                         WRITE (*,*) '    d Q(3)/dt: ', RECORD(11)
C                         WRITE (*,*) '        AV(1): ', RECORD(12)
C                         WRITE (*,*) '        AV(2): ', RECORD(13)
C                         WRITE (*,*) '        AV(3): ', RECORD(14)
C                         WRITE (*,*) '   d AV(1)/dt: ', RECORD(15)
C                         WRITE (*,*) '   d AV(2)/dt: ', RECORD(16)
C                         WRITE (*,*) '   d AV(3)/dt: ', RECORD(17)
C
C                      ELSE IF ( SUBTYP .EQ. C06TP3 ) THEN
C
C                         WRITE (*,*) '         Q(0): ', RECORD(4)
C                         WRITE (*,*) '         Q(1): ', RECORD(5)
C                         WRITE (*,*) '         Q(2): ', RECORD(6)
C                         WRITE (*,*) '         Q(3): ', RECORD(7)
C                         WRITE (*,*) '        AV(1): ', RECORD(8)
C                         WRITE (*,*) '        AV(2): ', RECORD(9)
C                         WRITE (*,*) '        AV(3): ', RECORD(10)
C
C                      ELSE
C                         CALL SETMSG ( 'Subtype # is not '
C            .            //            'recognized.'         )
C                         CALL ERRINT ( '#', SUBTYP           )
C                         CALL SIGERR ( 'SPICE(NOTSUPPORTED)' )
C                      END IF
C
C                      WRITE (*,*) ' '
C
C                  END DO
C
C                END DO
C
C                CALL DAFFNA ( FOUND )
C
C             END DO
C
C             END
C
C
C     An initial portion of the output created by this program, when
C     the program was executed on a PC/Linux/gfortran platform, for
C     a sample CK containing type 6 segments, is shown below:
C
C
C        Segment number:            1
C
C           Mini-segment number:            1
C              Rate:             1.52587890625000000E-005
C              Subtype:                   1
C              Window size:              10
C              Interval start:    11288914762710.869
C              Interval stop:     11290384616127.203
C              Last epoch:        11290384616127.203
C
C              Record number:            1
C                 SCLKDP:        11288914762710.869
C                 Clock rate:   1.52587890625000000E-005
C                 Q(0):   0.46164827229286126
C                 Q(1):  -0.70575355403199758
C                 Q(2):  -0.29319084125475281
C                 Q(3):  -0.45036865373250068
C
C              Record number:            2
C                 SCLKDP:        11288998883607.230
C                 Clock rate:   1.52587890625000000E-005
C                 Q(0):   0.46162099825988423
C                 Q(1):  -0.70570932104748119
C                 Q(2):  -0.29323821047130305
C                 Q(3):  -0.45043507864268195
C
C              Record number:            3
C                 SCLKDP:        11289077342579.063
C                 Clock rate:   1.52587890625000000E-005
C                 Q(0):   0.46159435700379842
C                 Q(1):  -0.70566850733850173
C                 Q(2):  -0.29328062251407311
C                 Q(3):  -0.45049870564815003
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman     (JPL)
C     J.M. Lynch       (JPL)
C     B.V. Semenov     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 14-MAR-2014 (NJB) (JML) (BVS)
C
C-&

C$ Index_Entries
C
C     get ck type_6 record
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
C        ND         is the number of double precision components in an
C                   unpacked C-kernel descriptor.
C
C        NI         is the number of integer components in an unpacked
C                   C-kernel descriptor.
C
C        DTYPE      is the data type of the segment that this routine
C                   operates on.
C

      INTEGER               ND
      PARAMETER           ( ND     = 2 )

      INTEGER               NI
      PARAMETER           ( NI     = 6 )

      INTEGER               DTYPE
      PARAMETER           ( DTYPE  = 6 )

      INTEGER               CTRLSZ
      PARAMETER           ( CTRLSZ = 2 )

C
C     Mini-segment control area size:
C
      INTEGER               MCTLSZ
      PARAMETER           ( MCTLSZ = 4 )

      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = MCTLSZ )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ = 100 )

C
C     Local variables
C
      DOUBLE PRECISION      BUFFER ( BUFSIZ )
      DOUBLE PRECISION      DC     ( ND )
      DOUBLE PRECISION      DPDATA ( 1  )
      DOUBLE PRECISION      RATE

      INTEGER               BADDR
      INTEGER               BUFBAS
      INTEGER               EADDR
      INTEGER               EPADDR
      INTEGER               EPCBAS
      INTEGER               IC     ( NI )
      INTEGER               MINIB
      INTEGER               MINIE
      INTEGER               NEPDIR
      INTEGER               NINTVL
      INTEGER               NREC
      INTEGER               PKTSIZ
      INTEGER               PKTSZS ( 0 : 3 )
      INTEGER               PTRBAS
      INTEGER               SUBTYP

C
C     Saved variables
C
      SAVE                  PKTSZS

C
C     Initial values
C
      DATA                  PKTSZS / C06PS0, C06PS1, C06PS2, C06PS3 /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'CKGR06' )

C
C     The number of discrete pointing instances contained in a data
C     type 6 segment is stored in the last double precision word of the
C     segment. Since the address of the last word is stored in the
C     sixth integer component of the segment descriptor, it is a
C     trivial matter to extract the count.
C
C     The unpacked descriptor contains the following information
C     about the segment:
C
C        DC(1)  Initial encoded SCLK
C        DC(2)  Final encoded SCLK
C
C        IC(1)  CK frame class ID (aka "instrument")
C        IC(2)  Inertial reference frame
C        IC(3)  Data type
C        IC(4)  Angular velocity flag
C        IC(5)  Initial address of segment data
C        IC(6)  Final address of segment data
C
C
      CALL DAFUS ( DESCR, ND, NI, DC, IC )

C
C     If this segment is not of data type 6, then signal an error.
C
      IF ( IC( 3 ) .NE. DTYPE ) THEN

         CALL SETMSG ( 'Data type of the segment should be 6: Passed '
     .   //            'descriptor shows type = #.'                   )
         CALL ERRINT ( '#', IC( 3 )                                   )
         CALL SIGERR ( 'SPICE(CKWRONGDATATYPE)'                       )
         CALL CHKOUT ( 'CKGR06'                                       )
         RETURN

      END IF

C
C     Check the mini-segment index.
C
C     The number of mini-segments is the final word in the segment.
C
      BADDR = IC(5)
      EADDR = IC(6)

      CALL DAFGDA ( HANDLE, EADDR, EADDR, DPDATA )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'CKGR06' )
         RETURN
      END IF

      NINTVL = NINT ( DPDATA(1) )

      IF (  ( MSNO .LT. 1 )  .OR.  ( MSNO .GT. NINTVL )  ) THEN

         CALL SETMSG ( 'Mini-segment index must be in range 1:# but '
     .   //            'was #.'                                       )
         CALL ERRINT ( '#', NINTVL                                    )
         CALL ERRINT ( '#', MSNO                                      )
         CALL SIGERR ( 'SPICE(INDEXOUTOFRANGE)'                       )
         CALL CHKOUT ( 'CKGR06'                                       )
         RETURN

      END IF

C
C     Set the base address of the mini-segment pointers. There
C     are NINTVL+1 pointers, and these precede the control area.
C
      PTRBAS = EADDR - CTRLSZ - ( NINTVL+1 )

C
C     Compute the mini-segment pointers as absolute
C     DAF addresses. The stored value is a relative address.
C
      BUFBAS = PTRBAS + MSNO - 1

      CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+2, BUFFER )

      IF ( FAILED() ) THEN
         CALL CHKOUT( 'CKGR06' )
         RETURN
      END IF

      MINIB = ( BADDR - 1 )  +  NINT( BUFFER(1) )
      MINIE = ( BADDR - 1 )  +  NINT( BUFFER(2) )  -  1

C
C     Fetch the control area of the mini-segment.
C
      BUFBAS = MINIE - MCTLSZ

      CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+MCTLSZ, BUFFER )

      IF ( FAILED() ) THEN
         CALL CHKOUT( 'CKGR06' )
         RETURN
      END IF

C
C     Fetch the SCLK rate (seconds per tick), mini-segment
C     subtype, and record count.
C
      RATE   =       BUFFER(1)
      SUBTYP = NINT( BUFFER(2) )
      NREC   = NINT( BUFFER(4) )

C
C     Compute the packet size for this mini-segment. This will
C     be used a bit later. We'll also check the subtype.
C
      IF (  ( SUBTYP .LT. C06TP0 ) .OR. ( SUBTYP .GT. C06TP3 )  ) THEN

         CALL SETMSG ( 'Unexpected CK type 6 subtype # '
     .   //            'found in mini-segment #.'       )
         CALL ERRINT ( '#',  SUBTYP                     )
         CALL ERRINT ( '#',  MSNO                       )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'            )
         CALL CHKOUT ( 'CKGR06'                         )
         RETURN

      END IF

      PKTSIZ = PKTSZS ( SUBTYP )

C
C     Check the record index.
C
      IF (  ( RECNO .LT. 1 )  .OR.  ( RECNO .GT. NREC )  ) THEN

         CALL SETMSG ( 'Record index must be in range 1:# but '
     .   //            'was #.'                                 )
         CALL ERRINT ( '#', NREC                                )
         CALL ERRINT ( '#', RECNO                               )
         CALL SIGERR ( 'SPICE(CKNONEXISTREC)'                   )
         CALL CHKOUT ( 'CKGR06'                                 )
         RETURN

      END IF

C
C     The epochs of the mini-segment precede the
C     mini-segment's control area and the epoch directories.
C
      NEPDIR = ( NREC - 1 ) / DIRSIZ

      EPCBAS = MINIE - MCTLSZ - NEPDIR - NREC

C
C     Fetch the mini-segment's epoch at index RECNO into
C     element 1 of the output record.
C
      EPADDR = EPCBAS + RECNO

      CALL DAFGDA ( HANDLE, EPADDR, EPADDR, RECORD )

C
C     Transfer the subtype and rate to the output record.
C
      RECORD(2) = DBLE ( SUBTYP )
      RECORD(3) = RATE

C
C     Locate the data packet at index RECNO.
C
      BUFBAS = ( MINIB - 1 )  +  ( ( RECNO - 1 ) * PKTSIZ )

      CALL DAFGDA ( HANDLE, BUFBAS+1, BUFBAS+PKTSIZ, RECORD(4) )

C
C     The record is complete if DAFGDA did its job. We don't
C     check FAILED here since we're about to return.
C
      CALL CHKOUT ( 'CKGR06' )
      RETURN
      END


      module comsptr
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Include file containing passed parameters and pointers related to
!D1 the streamline particle tracking option.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.0, SC-194
!D2 Initial implementation: 30-APR-1998, Programmer: G. Roemer
!D2
!D2 $Log:   /pvcs.config/fehm90/src/comsptr.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:42   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:00:08   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:07:42   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:35:48   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.2   06 Jun 2001 08:26:00   pvcs
!D2 Update for extended dispersion tensor model
!D2
!D2    Rev 2.1   30 Nov 2000 11:58:22   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:00 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 N/A
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 None
!D4
!***********************************************************************

      logical :: random_flag = .false.
      logical :: sptrak = .false.
      logical :: unstruct_sptr = .false.
      real*8, allocatable :: ddx(:),ddy(:),ddz(:)
      real*8, allocatable :: ggg(:,:)
      real*8, allocatable :: corn(:,:)
      real*8, allocatable :: ddxv(:)
      real*8, allocatable :: vx1(:)
      real*8, allocatable :: axv(:)
      real*8, allocatable :: x1(:),x2(:),x3(:)
      real*8, allocatable :: vx1bv(:),vx2bv(:)
      real*8, allocatable :: dtx(:),x_new(:)
      real*8, allocatable :: ddyv(:)
      real*8, allocatable :: vy1(:)
      real*8, allocatable :: ayv(:)
      real*8, allocatable :: y1(:),y2(:),y3(:)
      real*8, allocatable :: vy1bv(:),vy2bv(:)
      real*8, allocatable :: dty(:),y_new(:)
      real*8, allocatable :: ddzv(:)
      real*8, allocatable :: vz1(:)
      real*8, allocatable :: azv(:)
      real*8, allocatable :: z1(:),z2(:),z3(:)
      real*8, allocatable :: vz1bv(:),vz2bv(:)
      real*8, allocatable :: dtz(:),z_new(:)
      real*8, allocatable :: tt(:),dt(:),x61(:),axyzm(:),ttt(:),ttp1(:)
      integer, allocatable :: ioutt(:),istop(:),ijkv(:),ic_new(:)
      integer, allocatable :: irray(:,:),ijkvs(:)
      integer, allocatable :: exit_node(:)
      real*8, allocatable :: xo(:),yo(:),zo(:),ttpo(:)
      integer, allocatable :: ijkvss(:)
      real*8, allocatable :: vx(:),vy(:),vz(:)
      real*8, allocatable :: omega_partial(:)
      real*8, allocatable :: sigma_partial(:)
c     changed from al1, al2, ... to dispersivity1, dispersivity2,
c     to avoid conflict with other variable names in the code
      real*8, allocatable :: dispersivity1(:)
      real*8, allocatable :: dispersivity2(:)
      real*8, allocatable :: dispersivity3(:)
      real*8, allocatable :: dispersivity4(:)
      real*8, allocatable :: dispersivity6(:)
      real*8, allocatable :: dispersivity7(:)
      real*8, allocatable :: dispersivity8(:)
      real*8, allocatable :: vratio(:)
      real*8, allocatable :: divdwt(:)
      real*8, allocatable :: edtmax(:)
      real*8, allocatable :: gradd(:,:)
      integer, allocatable :: izonebtc(:,:)
      integer, allocatable :: zbtc(:)
      integer, allocatable :: totlast(:,:)
      integer, allocatable :: totalpart(:)
c zvd 24-Jul-07
c Added totalpart_ret, totlast_ret for importance sampling
c Changed totalpart back to an integer
      real*8, allocatable :: totalpart_ret(:)
      real*8, allocatable :: totlast_ret(:)

      integer, allocatable :: tprpflag(:)
      integer, allocatable :: part_id(:,:)

c...skelkar  7/23/01 ........................
      integer, allocatable :: izoneplum(:,:)
      integer, allocatable :: plum(:)
      integer, allocatable :: plumpart(:)
      integer nplum
c...........................................

      real*8, allocatable :: divd_omr(:,:)
      real*8, allocatable :: dpordx_omr(:,:)

      real*8  divd(3), dpordx(3), dtensor(3,3)
      real*8  divd_weight

      integer nzbtc
      integer num_part
      integer nsize_tprp
! ZVD - 05/05 Added for increasing btc time steps
      real*8 dtmx, dtmn
! ZVD - 06/05 Added for limiting path output (iprto > 0)
      integer linelim
      real*8 distlim, tplim
      integer iprt,iprto
      integer iprtr
      integer ial
      real*8 courant_factor
c      real*8 al1,al2,al3,al4,al5
      integer itm,ist
      integer nx,ny,nz
      real*8 x10,y10,z10
      real*8 xdim,ydim,zdim
      real*8 tt1
      integer nsptrprops
      parameter(nsptrprops=20)
      integer write_prop(nsptrprops)
      real*8 sptr_prop(nsptrprops)
      integer itensor
      integer irevers
! ZVD - 05/05 Added for increasing btc time steps
      integer delta_part, part_frac, part_steps
      real*8 part_mult, time_btc

c...skelkar  11/13/02 ........................
c if freez_time is gt.0, then ptrac3 is called only at the end of the
c flow calculations, and for a velocity frozen at that time,
c particle tracks are calculated for freez_time days
      real*8 freez_time
c....................................
! ZVD - 08/10/05 Added for saving particle loactions and time for restarting sptr runs
c s kelkar sep 17 05 - sptrx_flag
! Use ttp1 instead of time_sptr
!      real*8, allocatable :: time_sptr(:)

      logical btc_flag, alt_btc, pod_flag, xyz_flag, xyz_flag2
      logical ip_flag, sptr_flag, sptr_snode, sptrx_flag, trans_flag
      logical sptr_exists
c
      real*8, allocatable :: well_radius(:)

! ZVD - 08/11/05 Added for tracking time particle reaches a btc zone
      real*8, allocatable :: ttbtc(:,:)
! ZVD - 04/06/09 Added for output location of particles that have been removed from system dure to bad location
      integer, allocatable :: lastnode(:)
! ZVD - 07/15/09 Add to mark wheter or not the starting particle location has been output
      logical, allocatable :: pstart_out(:)
! ZVD - 02/16/2010 Add variable to flag whether particles outside the model domain should be included in the simualtion
      logical :: exclude_particle
! ZVD - 03/04/2010 Add variable to force output of particle location in sptr2 if its start time is greater than the simulation end time
      logical :: output_end

      end module comsptr


      SUBROUTINE SMATRIX_1(P,ANS)
C
C     Generated by MadGraph5_aMC@NLO v. 2.6.7, 2019-10-16
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     and helicities
C     for the point in phase space P(0:3,NEXTERNAL)
C
C     Process: g g > h > e+ e- e+ e- g NP<=2 QCD<=5 QED<=4
C      WEIGHTED<=28 [ all = QCD ]
C     Process: g g > h > mu+ mu- mu+ mu- g NP<=2 QCD<=5 QED<=4
C      WEIGHTED<=28 [ all = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INCLUDE 'nexternal.inc'
      INTEGER     NCOMB
      PARAMETER ( NCOMB=128)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL),ANS
      DOUBLE PRECISION       WGT_ME_BORN,WGT_ME_REAL
      COMMON /C_WGT_ME_TREE/ WGT_ME_BORN,WGT_ME_REAL
C
C     LOCAL VARIABLES
C
      INTEGER IHEL,IDEN,I,T_IDENT(NCOMB)
      REAL*8 MATRIX_1
      REAL*8 T,T_SAVE(NCOMB)
      SAVE T_SAVE,T_IDENT
      INTEGER NHEL(NEXTERNAL,NCOMB)
      DATA (NHEL(I,   1),I=1,7) /-1,-1, 1,-1, 1,-1,-1/
      DATA (NHEL(I,   2),I=1,7) /-1,-1, 1,-1, 1,-1, 1/
      DATA (NHEL(I,   3),I=1,7) /-1,-1, 1,-1, 1, 1,-1/
      DATA (NHEL(I,   4),I=1,7) /-1,-1, 1,-1, 1, 1, 1/
      DATA (NHEL(I,   5),I=1,7) /-1,-1, 1,-1,-1,-1,-1/
      DATA (NHEL(I,   6),I=1,7) /-1,-1, 1,-1,-1,-1, 1/
      DATA (NHEL(I,   7),I=1,7) /-1,-1, 1,-1,-1, 1,-1/
      DATA (NHEL(I,   8),I=1,7) /-1,-1, 1,-1,-1, 1, 1/
      DATA (NHEL(I,   9),I=1,7) /-1,-1, 1, 1, 1,-1,-1/
      DATA (NHEL(I,  10),I=1,7) /-1,-1, 1, 1, 1,-1, 1/
      DATA (NHEL(I,  11),I=1,7) /-1,-1, 1, 1, 1, 1,-1/
      DATA (NHEL(I,  12),I=1,7) /-1,-1, 1, 1, 1, 1, 1/
      DATA (NHEL(I,  13),I=1,7) /-1,-1, 1, 1,-1,-1,-1/
      DATA (NHEL(I,  14),I=1,7) /-1,-1, 1, 1,-1,-1, 1/
      DATA (NHEL(I,  15),I=1,7) /-1,-1, 1, 1,-1, 1,-1/
      DATA (NHEL(I,  16),I=1,7) /-1,-1, 1, 1,-1, 1, 1/
      DATA (NHEL(I,  17),I=1,7) /-1,-1,-1,-1, 1,-1,-1/
      DATA (NHEL(I,  18),I=1,7) /-1,-1,-1,-1, 1,-1, 1/
      DATA (NHEL(I,  19),I=1,7) /-1,-1,-1,-1, 1, 1,-1/
      DATA (NHEL(I,  20),I=1,7) /-1,-1,-1,-1, 1, 1, 1/
      DATA (NHEL(I,  21),I=1,7) /-1,-1,-1,-1,-1,-1,-1/
      DATA (NHEL(I,  22),I=1,7) /-1,-1,-1,-1,-1,-1, 1/
      DATA (NHEL(I,  23),I=1,7) /-1,-1,-1,-1,-1, 1,-1/
      DATA (NHEL(I,  24),I=1,7) /-1,-1,-1,-1,-1, 1, 1/
      DATA (NHEL(I,  25),I=1,7) /-1,-1,-1, 1, 1,-1,-1/
      DATA (NHEL(I,  26),I=1,7) /-1,-1,-1, 1, 1,-1, 1/
      DATA (NHEL(I,  27),I=1,7) /-1,-1,-1, 1, 1, 1,-1/
      DATA (NHEL(I,  28),I=1,7) /-1,-1,-1, 1, 1, 1, 1/
      DATA (NHEL(I,  29),I=1,7) /-1,-1,-1, 1,-1,-1,-1/
      DATA (NHEL(I,  30),I=1,7) /-1,-1,-1, 1,-1,-1, 1/
      DATA (NHEL(I,  31),I=1,7) /-1,-1,-1, 1,-1, 1,-1/
      DATA (NHEL(I,  32),I=1,7) /-1,-1,-1, 1,-1, 1, 1/
      DATA (NHEL(I,  33),I=1,7) /-1, 1, 1,-1, 1,-1,-1/
      DATA (NHEL(I,  34),I=1,7) /-1, 1, 1,-1, 1,-1, 1/
      DATA (NHEL(I,  35),I=1,7) /-1, 1, 1,-1, 1, 1,-1/
      DATA (NHEL(I,  36),I=1,7) /-1, 1, 1,-1, 1, 1, 1/
      DATA (NHEL(I,  37),I=1,7) /-1, 1, 1,-1,-1,-1,-1/
      DATA (NHEL(I,  38),I=1,7) /-1, 1, 1,-1,-1,-1, 1/
      DATA (NHEL(I,  39),I=1,7) /-1, 1, 1,-1,-1, 1,-1/
      DATA (NHEL(I,  40),I=1,7) /-1, 1, 1,-1,-1, 1, 1/
      DATA (NHEL(I,  41),I=1,7) /-1, 1, 1, 1, 1,-1,-1/
      DATA (NHEL(I,  42),I=1,7) /-1, 1, 1, 1, 1,-1, 1/
      DATA (NHEL(I,  43),I=1,7) /-1, 1, 1, 1, 1, 1,-1/
      DATA (NHEL(I,  44),I=1,7) /-1, 1, 1, 1, 1, 1, 1/
      DATA (NHEL(I,  45),I=1,7) /-1, 1, 1, 1,-1,-1,-1/
      DATA (NHEL(I,  46),I=1,7) /-1, 1, 1, 1,-1,-1, 1/
      DATA (NHEL(I,  47),I=1,7) /-1, 1, 1, 1,-1, 1,-1/
      DATA (NHEL(I,  48),I=1,7) /-1, 1, 1, 1,-1, 1, 1/
      DATA (NHEL(I,  49),I=1,7) /-1, 1,-1,-1, 1,-1,-1/
      DATA (NHEL(I,  50),I=1,7) /-1, 1,-1,-1, 1,-1, 1/
      DATA (NHEL(I,  51),I=1,7) /-1, 1,-1,-1, 1, 1,-1/
      DATA (NHEL(I,  52),I=1,7) /-1, 1,-1,-1, 1, 1, 1/
      DATA (NHEL(I,  53),I=1,7) /-1, 1,-1,-1,-1,-1,-1/
      DATA (NHEL(I,  54),I=1,7) /-1, 1,-1,-1,-1,-1, 1/
      DATA (NHEL(I,  55),I=1,7) /-1, 1,-1,-1,-1, 1,-1/
      DATA (NHEL(I,  56),I=1,7) /-1, 1,-1,-1,-1, 1, 1/
      DATA (NHEL(I,  57),I=1,7) /-1, 1,-1, 1, 1,-1,-1/
      DATA (NHEL(I,  58),I=1,7) /-1, 1,-1, 1, 1,-1, 1/
      DATA (NHEL(I,  59),I=1,7) /-1, 1,-1, 1, 1, 1,-1/
      DATA (NHEL(I,  60),I=1,7) /-1, 1,-1, 1, 1, 1, 1/
      DATA (NHEL(I,  61),I=1,7) /-1, 1,-1, 1,-1,-1,-1/
      DATA (NHEL(I,  62),I=1,7) /-1, 1,-1, 1,-1,-1, 1/
      DATA (NHEL(I,  63),I=1,7) /-1, 1,-1, 1,-1, 1,-1/
      DATA (NHEL(I,  64),I=1,7) /-1, 1,-1, 1,-1, 1, 1/
      DATA (NHEL(I,  65),I=1,7) / 1,-1, 1,-1, 1,-1,-1/
      DATA (NHEL(I,  66),I=1,7) / 1,-1, 1,-1, 1,-1, 1/
      DATA (NHEL(I,  67),I=1,7) / 1,-1, 1,-1, 1, 1,-1/
      DATA (NHEL(I,  68),I=1,7) / 1,-1, 1,-1, 1, 1, 1/
      DATA (NHEL(I,  69),I=1,7) / 1,-1, 1,-1,-1,-1,-1/
      DATA (NHEL(I,  70),I=1,7) / 1,-1, 1,-1,-1,-1, 1/
      DATA (NHEL(I,  71),I=1,7) / 1,-1, 1,-1,-1, 1,-1/
      DATA (NHEL(I,  72),I=1,7) / 1,-1, 1,-1,-1, 1, 1/
      DATA (NHEL(I,  73),I=1,7) / 1,-1, 1, 1, 1,-1,-1/
      DATA (NHEL(I,  74),I=1,7) / 1,-1, 1, 1, 1,-1, 1/
      DATA (NHEL(I,  75),I=1,7) / 1,-1, 1, 1, 1, 1,-1/
      DATA (NHEL(I,  76),I=1,7) / 1,-1, 1, 1, 1, 1, 1/
      DATA (NHEL(I,  77),I=1,7) / 1,-1, 1, 1,-1,-1,-1/
      DATA (NHEL(I,  78),I=1,7) / 1,-1, 1, 1,-1,-1, 1/
      DATA (NHEL(I,  79),I=1,7) / 1,-1, 1, 1,-1, 1,-1/
      DATA (NHEL(I,  80),I=1,7) / 1,-1, 1, 1,-1, 1, 1/
      DATA (NHEL(I,  81),I=1,7) / 1,-1,-1,-1, 1,-1,-1/
      DATA (NHEL(I,  82),I=1,7) / 1,-1,-1,-1, 1,-1, 1/
      DATA (NHEL(I,  83),I=1,7) / 1,-1,-1,-1, 1, 1,-1/
      DATA (NHEL(I,  84),I=1,7) / 1,-1,-1,-1, 1, 1, 1/
      DATA (NHEL(I,  85),I=1,7) / 1,-1,-1,-1,-1,-1,-1/
      DATA (NHEL(I,  86),I=1,7) / 1,-1,-1,-1,-1,-1, 1/
      DATA (NHEL(I,  87),I=1,7) / 1,-1,-1,-1,-1, 1,-1/
      DATA (NHEL(I,  88),I=1,7) / 1,-1,-1,-1,-1, 1, 1/
      DATA (NHEL(I,  89),I=1,7) / 1,-1,-1, 1, 1,-1,-1/
      DATA (NHEL(I,  90),I=1,7) / 1,-1,-1, 1, 1,-1, 1/
      DATA (NHEL(I,  91),I=1,7) / 1,-1,-1, 1, 1, 1,-1/
      DATA (NHEL(I,  92),I=1,7) / 1,-1,-1, 1, 1, 1, 1/
      DATA (NHEL(I,  93),I=1,7) / 1,-1,-1, 1,-1,-1,-1/
      DATA (NHEL(I,  94),I=1,7) / 1,-1,-1, 1,-1,-1, 1/
      DATA (NHEL(I,  95),I=1,7) / 1,-1,-1, 1,-1, 1,-1/
      DATA (NHEL(I,  96),I=1,7) / 1,-1,-1, 1,-1, 1, 1/
      DATA (NHEL(I,  97),I=1,7) / 1, 1, 1,-1, 1,-1,-1/
      DATA (NHEL(I,  98),I=1,7) / 1, 1, 1,-1, 1,-1, 1/
      DATA (NHEL(I,  99),I=1,7) / 1, 1, 1,-1, 1, 1,-1/
      DATA (NHEL(I, 100),I=1,7) / 1, 1, 1,-1, 1, 1, 1/
      DATA (NHEL(I, 101),I=1,7) / 1, 1, 1,-1,-1,-1,-1/
      DATA (NHEL(I, 102),I=1,7) / 1, 1, 1,-1,-1,-1, 1/
      DATA (NHEL(I, 103),I=1,7) / 1, 1, 1,-1,-1, 1,-1/
      DATA (NHEL(I, 104),I=1,7) / 1, 1, 1,-1,-1, 1, 1/
      DATA (NHEL(I, 105),I=1,7) / 1, 1, 1, 1, 1,-1,-1/
      DATA (NHEL(I, 106),I=1,7) / 1, 1, 1, 1, 1,-1, 1/
      DATA (NHEL(I, 107),I=1,7) / 1, 1, 1, 1, 1, 1,-1/
      DATA (NHEL(I, 108),I=1,7) / 1, 1, 1, 1, 1, 1, 1/
      DATA (NHEL(I, 109),I=1,7) / 1, 1, 1, 1,-1,-1,-1/
      DATA (NHEL(I, 110),I=1,7) / 1, 1, 1, 1,-1,-1, 1/
      DATA (NHEL(I, 111),I=1,7) / 1, 1, 1, 1,-1, 1,-1/
      DATA (NHEL(I, 112),I=1,7) / 1, 1, 1, 1,-1, 1, 1/
      DATA (NHEL(I, 113),I=1,7) / 1, 1,-1,-1, 1,-1,-1/
      DATA (NHEL(I, 114),I=1,7) / 1, 1,-1,-1, 1,-1, 1/
      DATA (NHEL(I, 115),I=1,7) / 1, 1,-1,-1, 1, 1,-1/
      DATA (NHEL(I, 116),I=1,7) / 1, 1,-1,-1, 1, 1, 1/
      DATA (NHEL(I, 117),I=1,7) / 1, 1,-1,-1,-1,-1,-1/
      DATA (NHEL(I, 118),I=1,7) / 1, 1,-1,-1,-1,-1, 1/
      DATA (NHEL(I, 119),I=1,7) / 1, 1,-1,-1,-1, 1,-1/
      DATA (NHEL(I, 120),I=1,7) / 1, 1,-1,-1,-1, 1, 1/
      DATA (NHEL(I, 121),I=1,7) / 1, 1,-1, 1, 1,-1,-1/
      DATA (NHEL(I, 122),I=1,7) / 1, 1,-1, 1, 1,-1, 1/
      DATA (NHEL(I, 123),I=1,7) / 1, 1,-1, 1, 1, 1,-1/
      DATA (NHEL(I, 124),I=1,7) / 1, 1,-1, 1, 1, 1, 1/
      DATA (NHEL(I, 125),I=1,7) / 1, 1,-1, 1,-1,-1,-1/
      DATA (NHEL(I, 126),I=1,7) / 1, 1,-1, 1,-1,-1, 1/
      DATA (NHEL(I, 127),I=1,7) / 1, 1,-1, 1,-1, 1,-1/
      DATA (NHEL(I, 128),I=1,7) / 1, 1,-1, 1,-1, 1, 1/
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      INTEGER NTRY
      DATA NTRY/0/
      DATA IDEN/1024/
C     ----------
C     BEGIN CODE
C     ----------
      NTRY=NTRY+1
      ANS = 0D0
      DO IHEL=1,NCOMB
        IF (GOODHEL(IHEL) .OR. NTRY .LT. 2) THEN
          IF (NTRY.LT.2) THEN
C           for the first ps-point, check for helicities that give
C           identical matrix elements
            T=MATRIX_1(P ,NHEL(1,IHEL))
            T_SAVE(IHEL)=T
            T_IDENT(IHEL)=-1
            DO I=1,IHEL-1
              IF (T.EQ.0D0) EXIT
              IF (T_SAVE(I).EQ.0D0) CYCLE
              IF (ABS(T/T_SAVE(I)-1D0) .LT. 1D-12) THEN
C               WRITE (*,*) 'FOUND IDENTICAL',T,IHEL,T_SAVE(I),I
                T_IDENT(IHEL) = I
              ENDIF
            ENDDO
          ELSE
            IF (T_IDENT(IHEL).GT.0) THEN
C             if two helicity states are identical, dont recompute
              T=T_SAVE(T_IDENT(IHEL))
              T_SAVE(IHEL)=T
            ELSE
              T=MATRIX_1(P ,NHEL(1,IHEL))
              T_SAVE(IHEL)=T
            ENDIF
          ENDIF
C         add to the sum of helicities
          ANS=ANS+T
          IF (T .NE. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
            GOODHEL(IHEL)=.TRUE.
          ENDIF
        ENDIF
      ENDDO
      ANS=ANS/DBLE(IDEN)
      WGT_ME_REAL=ANS
      END

      REAL*8 FUNCTION MATRIX_1(P,NHEL)
C
C     Generated by MadGraph5_aMC@NLO v. 2.6.7, 2019-10-16
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     for the point with external lines W(0:6,NEXTERNAL)
C
C     Process: g g > h > e+ e- e+ e- g NP<=2 QCD<=5 QED<=4
C      WEIGHTED<=28 [ all = QCD ]
C     Process: g g > h > mu+ mu- mu+ mu- g NP<=2 QCD<=5 QED<=4
C      WEIGHTED<=28 [ all = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NGRAPHS
      PARAMETER (NGRAPHS=8)
      INTEGER    NWAVEFUNCS, NCOLOR
      PARAMETER (NWAVEFUNCS=11, NCOLOR=2)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      COMPLEX*16 IMAG1
      PARAMETER (IMAG1=(0D0,1D0))
      INCLUDE 'nexternal.inc'
      INCLUDE 'coupl.inc'
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL)
C
C     LOCAL VARIABLES
C
      INTEGER I,J
      INTEGER IC(NEXTERNAL)
      DATA IC /NEXTERNAL*1/
      REAL*8 DENOM(NCOLOR), CF(NCOLOR,NCOLOR)
      COMPLEX*16 ZTEMP, AMP(NGRAPHS), JAMP(NCOLOR), W(8,NWAVEFUNCS)
C
C     COLOR DATA
C
      DATA DENOM(1)/3/
      DATA (CF(I,  1),I=  1,  2) /    7,   -2/
C     1 Tr(1,2,7)
      DATA DENOM(2)/3/
      DATA (CF(I,  2),I=  1,  2) /   -2,    7/
C     1 Tr(1,7,2)
C     ----------
C     BEGIN CODE
C     ----------
      CALL VXXXXX(P(0,1),ZERO,NHEL(1),-1*IC(1),W(1,1))
      CALL VXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
      CALL IXXXXX(P(0,3),ZERO,NHEL(3),-1*IC(3),W(1,3))
      CALL OXXXXX(P(0,4),ZERO,NHEL(4),+1*IC(4),W(1,4))
      CALL IXXXXX(P(0,5),ZERO,NHEL(5),-1*IC(5),W(1,5))
      CALL OXXXXX(P(0,6),ZERO,NHEL(6),+1*IC(6),W(1,6))
      CALL VXXXXX(P(0,7),ZERO,NHEL(7),+1*IC(7),W(1,7))
      CALL VVV3P0_1(W(1,1),W(1,2),GC_10,ZERO,ZERO,W(1,8))
      CALL FFV12_2_3(W(1,3),W(1,4),GC_317,GC_243,MDL_MZ,MDL_WZ,W(1,9))
      CALL FFV12_2_3(W(1,5),W(1,6),GC_317,GC_243,MDL_MZ,MDL_WZ,W(1,10))
      CALL VVS4_3(W(1,8),W(1,7),GC_426,MDL_MH,MDL_WH,W(1,11))
C     Amplitude(s) for diagram number 1
      CALL VVS3_0(W(1,9),W(1,10),W(1,11),GC_588,AMP(1))
      CALL FFV12_2_3(W(1,3),W(1,6),GC_317,GC_243,MDL_MZ,MDL_WZ,W(1,8))
      CALL FFV12_2_3(W(1,5),W(1,4),GC_317,GC_243,MDL_MZ,MDL_WZ,W(1,6))
C     Amplitude(s) for diagram number 2
      CALL VVS3_0(W(1,8),W(1,6),W(1,11),GC_588,AMP(2))
      CALL VVV3P0_1(W(1,1),W(1,7),GC_10,ZERO,ZERO,W(1,11))
      CALL VVS4_3(W(1,11),W(1,2),GC_426,MDL_MH,MDL_WH,W(1,5))
C     Amplitude(s) for diagram number 3
      CALL VVS3_0(W(1,9),W(1,10),W(1,5),GC_588,AMP(3))
C     Amplitude(s) for diagram number 4
      CALL VVS3_0(W(1,8),W(1,6),W(1,5),GC_588,AMP(4))
      CALL VVV3P0_1(W(1,2),W(1,7),GC_10,ZERO,ZERO,W(1,5))
      CALL VVS4_3(W(1,1),W(1,5),GC_426,MDL_MH,MDL_WH,W(1,11))
C     Amplitude(s) for diagram number 5
      CALL VVS3_0(W(1,9),W(1,10),W(1,11),GC_588,AMP(5))
C     Amplitude(s) for diagram number 6
      CALL VVS3_0(W(1,8),W(1,6),W(1,11),GC_588,AMP(6))
      CALL VVVS9_4(W(1,1),W(1,2),W(1,7),GC_457,MDL_MH,MDL_WH,W(1,11))
C     Amplitude(s) for diagram number 7
      CALL VVS3_0(W(1,9),W(1,10),W(1,11),GC_588,AMP(7))
C     Amplitude(s) for diagram number 8
      CALL VVS3_0(W(1,8),W(1,6),W(1,11),GC_588,AMP(8))
      JAMP(1)=+2D0*(-IMAG1*AMP(1)+IMAG1*AMP(2)+IMAG1*AMP(3)-IMAG1
     $ *AMP(4)-IMAG1*AMP(5)+IMAG1*AMP(6)-IMAG1*AMP(7)+IMAG1*AMP(8))
      JAMP(2)=+2D0*(+IMAG1*AMP(1)-IMAG1*AMP(2)-IMAG1*AMP(3)+IMAG1
     $ *AMP(4)+IMAG1*AMP(5)-IMAG1*AMP(6)+IMAG1*AMP(7)-IMAG1*AMP(8))
      MATRIX_1 = 0.D0
      DO I = 1, NCOLOR
        ZTEMP = (0.D0,0.D0)
        DO J = 1, NCOLOR
          ZTEMP = ZTEMP + CF(J,I)*JAMP(J)
        ENDDO
        MATRIX_1 = MATRIX_1+ZTEMP*DCONJG(JAMP(I))/DENOM(I)
      ENDDO
      END