C$Procedure  DRDPGR ( Derivative of rectangular w.r.t. planetographic )

      SUBROUTINE DRDPGR ( BODY, LON, LAT, ALT, RE, F, JACOBI )

C$ Abstract
C
C     This routine computes the Jacobian matrix of the transformation
C     from planetographic to rectangular coordinates.
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     None.
C
C$ Keywords
C
C     COORDINATES
C     DERIVATIVES
C     MATRIX
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzctr.inc'

      CHARACTER*(*)         BODY
      DOUBLE PRECISION      LON
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      ALT
      DOUBLE PRECISION      RE
      DOUBLE PRECISION      F
      DOUBLE PRECISION      JACOBI ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     BODY       I   Name of body with which coordinates are associated.
C     LON        I   Planetographic longitude of a point (radians).
C     LAT        I   Planetographic latitude of a point (radians).
C     ALT        I   Altitude of a point above reference spheroid.
C     RE         I   Equatorial radius of the reference spheroid.
C     F          I   Flattening coefficient.
C     JACOBI     O   Matrix of partial derivatives.
C
C$ Detailed_Input
C
C     BODY       Name of the body with which the planetographic
C                coordinate system is associated.
C
C                BODY is used by this routine to look up from the
C                kernel pool the prime meridian rate coefficient giving
C                the body's spin sense.  See the Files and Particulars
C                header sections below for details.
C
C     LON        Planetographic longitude of the input point.  This is
C                the angle between the prime meridian and the meridian
C                containing the input point.  For bodies having
C                prograde (aka direct) rotation, the direction of
C                increasing longitude is positive west:  from the +X
C                axis of the rectangular coordinate system toward the
C                -Y axis.  For bodies having retrograde rotation, the
C                direction of increasing longitude is positive east:
C                from the +X axis toward the +Y axis.
C
C                The earth, moon, and sun are exceptions:
C                planetographic longitude is measured positive east for
C                these bodies.
C
C                The default interpretation of longitude by this
C                and the other planetographic coordinate conversion
C                routines can be overridden; see the discussion in
C                Particulars below for details.
C
C                Longitude is measured in radians. On input, the range
C                of longitude is unrestricted.
C
C     LAT        Planetographic latitude of the input point.  For a
C                point P on the reference spheroid, this is the angle
C                between the XY plane and the outward normal vector at
C                P. For a point P not on the reference spheroid, the
C                planetographic latitude is that of the closest point
C                to P on the spheroid.
C
C                Latitude is measured in radians.  On input, the
C                range of latitude is unrestricted.
C
C     ALT        Altitude of point above the reference spheroid.
C                Units of ALT must match those of RE.
C
C     RE         Equatorial radius of a reference spheroid.  This
C                spheroid is a volume of revolution:  its horizontal
C                cross sections are circular.  The shape of the
C                spheroid is defined by an equatorial radius RE and
C                a polar radius RP.  Units of RE must match those of
C                ALT.
C
C     F          Flattening coefficient =
C
C                   (RE-RP) / RE
C
C                where RP is the polar radius of the spheroid, and the
C                units of RP match those of RE.
C
C$ Detailed_Output
C
C     JACOBI     is the matrix of partial derivatives of the conversion
C                from planetographic to rectangular coordinates.  It
C                has the form
C
C                   .-                              -.
C                   |  DX/DLON   DX/DLAT   DX/DALT   |
C                   |  DY/DLON   DY/DLAT   DY/DALT   |
C                   |  DZ/DLON   DZ/DLAT   DZ/DALT   |
C                   `-                              -'
C
C                evaluated at the input values of LON, LAT and ALT.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the body name BODY cannot be mapped to a NAIF ID code,
C        and if BODY is not a string representation of an integer,
C        the error SPICE(IDCODENOTFOUND) will be signaled.
C
C     2) If the kernel variable
C
C           BODY<ID code>_PGR_POSITIVE_LON
C
C        is present in the kernel pool but has a value other
C        than one of
C
C            'EAST'
C            'WEST'
C
C        the error SPICE(INVALIDOPTION) will be signaled.  Case
C        and blanks are ignored when these values are interpreted.
C
C     3) If polynomial coefficients for the prime meridian of BODY
C        are not available in the kernel pool, and if the kernel
C        variable BODY<ID code>_PGR_POSITIVE_LON is not present in
C        the kernel pool, the error SPICE(MISSINGDATA) will be signaled.
C
C     4) If the equatorial radius is non-positive, the error
C        SPICE(VALUEOUTOFRANGE) is signaled.
C
C     5) If the flattening coefficient is greater than or equal to one,
C        the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C$ Files
C
C     This routine expects a kernel variable giving BODY's prime
C     meridian angle as a function of time to be available in the
C     kernel pool.  Normally this item is provided by loading a PCK
C     file.  The required kernel variable is named
C
C        BODY<body ID>_PM
C
C     where <body ID> represents a string containing the NAIF integer
C     ID code for BODY.  For example, if BODY is 'JUPITER', then
C     the name of the kernel variable containing the prime meridian
C     angle coefficients is
C
C        BODY599_PM
C
C     See the PCK Required Reading for details concerning the prime
C     meridian kernel variable.
C
C     The optional kernel variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     also is normally defined via loading a text kernel. When this
C     variable is present in the kernel pool, the prime meridian
C     coefficients for BODY are not required by this routine. See the
C     Particulars section below for details.
C
C$ Particulars
C
C     It is often convenient to describe the motion of an object in the
C     planetographic coordinate system.  However, when performing
C     vector computations it's hard to beat rectangular coordinates.
C
C     To transform states given with respect to planetographic
C     coordinates to states with respect to rectangular coordinates,
C     one makes use of the Jacobian of the transformation between the
C     two systems.
C
C     Given a state in planetographic coordinates
C
C        ( lon, lat, alt, dlon, dlat, dalt )
C
C     the velocity in rectangular coordinates is given by the matrix
C     equation:
C
C                    t          |                                  t
C        (dx, dy, dz)   = JACOBI|              * (dlon, dlat, dalt)
C                               |(lon,lat,alt)
C
C
C     This routine computes the matrix
C
C              |
C        JACOBI|
C              |(lon,lat,alt)
C
C
C     In the planetographic coordinate system, longitude is defined
C     using the spin sense of the body.  Longitude is positive to the
C     west if the spin is prograde and positive to the east if the spin
C     is retrograde.  The spin sense is given by the sign of the first
C     degree term of the time-dependent polynomial for the body's prime
C     meridian Euler angle "W":  the spin is retrograde if this term is
C     negative and prograde otherwise.  For the sun, planets, most
C     natural satellites, and selected asteroids, the polynomial
C     expression for W may be found in a SPICE PCK kernel.
C
C     The earth, moon, and sun are exceptions: planetographic longitude
C     is measured positive east for these bodies.
C
C     If you wish to override the default sense of positive longitude
C     for a particular body, you can do so by defining the kernel
C     variable
C
C        BODY<body ID>_PGR_POSITIVE_LON
C
C     where <body ID> represents the NAIF ID code of the body. This
C     variable may be assigned either of the values
C
C        'WEST'
C        'EAST'
C
C     For example, you can have this routine treat the longitude
C     of the earth as increasing to the west using the kernel
C     variable assignment
C
C        BODY399_PGR_POSITIVE_LON = 'WEST'
C
C     Normally such assignments are made by placing them in a text
C     kernel and loading that kernel via FURNSH.
C
C     The definition of this kernel variable controls the behavior of
C     the SPICELIB planetographic routines
C
C        PGRREC
C        RECPGR
C        DPGRDR
C        DRDPGR
C
C     It does not affect the other SPICELIB coordinate conversion
C     routines.
C
C$ Examples
C
C     Numerical results shown for this example may differ between
C     platforms as the results depend on the SPICE kernels used as
C     input and the machine specific arithmetic implementation.
C
C
C         Find the planetographic state of the earth as seen from
C         Mars in the J2000 reference frame at January 1, 2005 TDB.
C         Map this state back to rectangular coordinates as a check.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     SPICELIB functions
C        C
C              DOUBLE PRECISION      RPD
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      ALT
C              DOUBLE PRECISION      DRECTN ( 3 )
C              DOUBLE PRECISION      ET
C              DOUBLE PRECISION      F
C              DOUBLE PRECISION      JACOBI ( 3, 3 )
C              DOUBLE PRECISION      LAT
C              DOUBLE PRECISION      LON
C              DOUBLE PRECISION      LT
C              DOUBLE PRECISION      PGRVEL ( 3 )
C              DOUBLE PRECISION      RADII  ( 3 )
C              DOUBLE PRECISION      RE
C              DOUBLE PRECISION      RECTAN ( 3 )
C              DOUBLE PRECISION      RP
C              DOUBLE PRECISION      STATE  ( 6 )
C
C              INTEGER               N
C        C
C        C     Load a PCK file containing a triaxial
C        C     ellipsoidal shape model and orientation
C        C     data for Mars.
C        C
C              CALL FURNSH ( 'pck00008.tpc' )
C
C        C
C        C     Load an SPK file giving ephemerides of earth and Mars.
C        C
C              CALL FURNSH ( 'de405.bsp' )
C
C        C
C        C     Load a leapseconds kernel to support time conversion.
C        C
C              CALL FURNSH ( 'naif0007.tls' )
C
C        C
C        C     Look up the radii for Mars.  Although we
C        C     omit it here, we could first call BADKPV
C        C     to make sure the variable BODY499_RADII
C        C     has three elements and numeric data type.
C        C     If the variable is not present in the kernel
C        C     pool, BODVRD will signal an error.
C        C
C              CALL BODVRD ( 'MARS', 'RADII', 3, N, RADII )
C
C        C
C        C     Compute flattening coefficient.
C        C
C              RE  =  RADII(1)
C              RP  =  RADII(3)
C              F   =  ( RE - RP ) / RE
C
C        C
C        C     Look up the geometric state of earth as seen from Mars at
C        C     January 1, 2005 TDB, relative to the J2000 reference
C        C     frame.
C        C
C              CALL STR2ET ( 'January 1, 2005 TDB', ET )
C
C              CALL SPKEZR ( 'Earth', ET,    'J2000', 'LT+S',
C             .              'Mars',  STATE, LT               )
C
C        C
C        C     Convert position to planetographic coordinates.
C        C
C              CALL RECPGR ( 'MARS', STATE, RE, F, LON, LAT, ALT )
C
C        C
C        C     Convert velocity to planetographic coordinates.
C        C
C
C              CALL DPGRDR ( 'MARS', STATE(1), STATE(2), STATE(3),
C             .               RE,    F,        JACOBI             )
C
C              CALL MXV ( JACOBI, STATE(4), PGRVEL )
C
C        C
C        C     As a check, convert the planetographic state back to
C        C     rectangular coordinates.
C        C
C              CALL PGRREC ( 'MARS', LON, LAT, ALT, RE, F, RECTAN )
C
C              CALL DRDPGR ( 'MARS', LON, LAT, ALT, RE, F, JACOBI )
C
C              CALL MXV ( JACOBI, PGRVEL, DRECTN )
C
C
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular coordinates:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  X (km)                 = ', STATE(1)
C              WRITE(*,*) '  Y (km)                 = ', STATE(2)
C              WRITE(*,*) '  Z (km)                 = ', STATE(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular velocity:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  dX/dt (km/s)           = ', STATE(4)
C              WRITE(*,*) '  dY/dt (km/s)           = ', STATE(5)
C              WRITE(*,*) '  dZ/dt (km/s)           = ', STATE(6)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Ellipsoid shape parameters: '
C              WRITE(*,*) ' '
C              WRITE(*,*) '  Equatorial radius (km) = ', RE
C              WRITE(*,*) '  Polar radius      (km) = ', RP
C              WRITE(*,*) '  Flattening coefficient = ', F
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Planetographic coordinates:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  Longitude (deg)        = ', LON / RPD()
C              WRITE(*,*) '  Latitude  (deg)        = ', LAT / RPD()
C              WRITE(*,*) '  Altitude  (km)         = ', ALT
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Planetographic velocity:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  d Longitude/dt (deg/s) = ', PGRVEL(1)/RPD()
C              WRITE(*,*) '  d Latitude/dt  (deg/s) = ', PGRVEL(2)/RPD()
C              WRITE(*,*) '  d Altitude/dt  (km/s)  = ', PGRVEL(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular coordinates from inverse ' //
C             .           'mapping:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  X (km)                 = ', RECTAN(1)
C              WRITE(*,*) '  Y (km)                 = ', RECTAN(2)
C              WRITE(*,*) '  Z (km)                 = ', RECTAN(3)
C              WRITE(*,*) ' '
C              WRITE(*,*) 'Rectangular velocity from inverse mapping:'
C              WRITE(*,*) ' '
C              WRITE(*,*) '  dX/dt (km/s)           = ', DRECTN(1)
C              WRITE(*,*) '  dY/dt (km/s)           = ', DRECTN(2)
C              WRITE(*,*) '  dZ/dt (km/s)           = ', DRECTN(3)
C              WRITE(*,*) ' '
C              END
C
C
C        Output from this program should be similar to the following
C        (rounding and formatting differ across platforms):
C
C
C           Rectangular coordinates:
C
C             X (km)                 =   146039732.
C             Y (km)                 =   278546607.
C             Z (km)                 =   119750315.
C
C           Rectangular velocity:
C
C             dX/dt (km/s)           =  -47.0428824
C             dY/dt (km/s)           =   9.07021778
C             dZ/dt (km/s)           =   4.75656274
C
C           Ellipsoid shape parameters:
C
C             Equatorial radius (km) =   3396.19
C             Polar radius      (km) =   3376.2
C             Flattening coefficient =   0.00588600756
C
C           Planetographic coordinates:
C
C             Longitude (deg)        =   297.667659
C             Latitude  (deg)        =   20.844504
C             Altitude  (km)         =   336531825.
C
C           Planetographic velocity:
C
C             d Longitude/dt (deg/s) =  -8.35738632E-06
C             d Latitude/dt  (deg/s) =   1.59349355E-06
C             d Altitude/dt  (km/s)  =  -11.2144327
C
C           Rectangular coordinates from inverse mapping:
C
C             X (km)                 =   146039732.
C             Y (km)                 =   278546607.
C             Z (km)                 =   119750315.
C
C           Rectangular velocity from inverse mapping:
C
C             dX/dt (km/s)           =  -47.0428824
C             dY/dt (km/s)           =   9.07021778
C             dZ/dt (km/s)           =   4.75656274
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     B.V. Semenov   (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 21-SEP-2013 (BVS)
C
C        Updated to save the input body name and ZZBODTRN state counter
C        and to do name-ID conversion only if the counter has changed.
C
C        Updated to call LJUCRS instead of CMPRSS/UCASE.
C
C-    SPICELIB Version 1.0.0, 26-DEC-2004 (NJB) (WLT)
C
C-&

C$ Index_Entries
C
C     Jacobian of rectangular w.r.t. planetographic coordinates
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               PLNSNS

      LOGICAL               RETURN

C
C     Local parameters
C
      CHARACTER*(*)         PMTMP
      PARAMETER           ( PMTMP  = 'BODY#_PM' )

      CHARACTER*(*)         OVRTMP
      PARAMETER           ( OVRTMP = 'BODY#_PGR_POSITIVE_LON' )

      INTEGER               EARTH
      PARAMETER           ( EARTH  = 399 )

      INTEGER               KVNMLN
      PARAMETER           ( KVNMLN = 32  )

      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80  )

      INTEGER               MOON
      PARAMETER           ( MOON   = 301 )

      INTEGER               SENSLN
      PARAMETER           ( SENSLN = 4 )

      INTEGER               SUN
      PARAMETER           ( SUN    = 10  )

C
C     Saved body name length.
C
      INTEGER               MAXL
      PARAMETER           ( MAXL  = 36 )

C
C     Local variables
C
      CHARACTER*(LNSIZE)    KVALUE
      CHARACTER*(KVNMLN)    PMKVAR
      CHARACTER*(SENSLN)    PGRLON

      DOUBLE PRECISION      GEOLON

      INTEGER               BODYID
      INTEGER               I
      INTEGER               N
      INTEGER               SENSE

      LOGICAL               FOUND

C
C     Saved name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(MAXL)      SVBODY
      INTEGER               SVBDID
      LOGICAL               SVFND1

      LOGICAL               FIRST

C
C     Saved name/ID items.
C
      SAVE                  SVCTR1
      SAVE                  SVBODY
      SAVE                  SVBDID
      SAVE                  SVFND1

      SAVE                  FIRST

C
C     Initial values.
C
      DATA                  FIRST   / .TRUE. /

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

      CALL CHKIN ( 'DRDPGR' )

C
C     Initialization.
C
      IF ( FIRST ) THEN

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

C
C     Convert the body name to an ID code.
C
      CALL ZZBODS2C ( SVCTR1, SVBODY, SVBDID, SVFND1,
     .                BODY, BODYID, FOUND    )

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The value of the input argument BODY is #, '
     .   //            'this is not a recognized name of an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', BODY                                  )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'DRDPGR'                                   )
         RETURN

      END IF

C
C     The equatorial radius must be positive. If not, signal an error
C     and check out.
C
      IF ( RE .LE. 0.0D0 ) THEN

         CALL SETMSG ( 'Equatorial radius was #.' )
         CALL ERRDP  ( '#', RE                    )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'   )
         CALL CHKOUT ( 'DRDPGR'                   )
         RETURN

      END IF

C
C     If the flattening coefficient is greater than 1, the polar radius
C     is negative. If F is equal to 1, the polar radius is zero. Either
C     case is a problem, so signal an error and check out.
C
      IF ( F .GE. 1.D0 ) THEN

         CALL SETMSG ( 'Flattening coefficient was #.'  )
         CALL ERRDP  ( '#', F                           )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'         )
         CALL CHKOUT ( 'DRDPGR'                         )
         RETURN

      END IF

C
C     Look up the longitude sense override variable from the
C     kernel pool.
C
      CALL REPMI  ( OVRTMP, '#',     BODYID, PMKVAR )
      CALL GCPOOL ( PMKVAR, 1, 1, N, KVALUE, FOUND  )

      IF ( FOUND ) THEN
C
C        Make sure we recognize the value of PGRLON.
C
         CALL LJUCRS ( 0, KVALUE, PGRLON )

         IF ( PGRLON .EQ. 'EAST' ) THEN

            SENSE =  1

         ELSE IF ( PGRLON .EQ. 'WEST' ) THEN

            SENSE = -1

         ELSE

            CALL SETMSG ( 'Kernel variable # may have the values ' //
     .                    'EAST or WEST.  Actual value was #.'    )
            CALL ERRCH  ( '#', PMKVAR                             )
            CALL ERRCH  ( '#', KVALUE                             )
            CALL SIGERR ( 'SPICE(INVALIDOPTION)'                  )
            CALL CHKOUT ( 'DRDPGR'                                )
            RETURN

         END IF

      ELSE
C
C        Look up the spin sense of the body's prime meridian.
C
         SENSE = PLNSNS ( BODYID )

C
C        If the required prime meridian rate was not available,
C        PLNSNS returns the code 0.  Here we consider this situation
C        to be an error.
C
         IF ( SENSE .EQ. 0 ) THEN

            CALL REPMI  ( PMTMP, '#', BODYID, PMKVAR )

            CALL SETMSG ( 'Prime meridian rate coefficient defined ' //
     .                    'by kernel variable # is required but '    //
     .                    'not available for body #. '               )
            CALL ERRCH  ( '#', PMKVAR                                )
            CALL ERRCH  ( '#', BODY                                  )
            CALL SIGERR ( 'SPICE(MISSINGDATA)'                       )
            CALL CHKOUT ( 'DRDPGR'                                   )
            RETURN

         END IF

C
C        Handle the special cases:  earth, moon, and sun.
C
         IF (      ( BODYID .EQ. EARTH )
     .        .OR. ( BODYID .EQ. MOON  )
     .        .OR. ( BODYID .EQ. SUN   )  ) THEN

            SENSE = 1

         END IF

      END IF

C
C     At this point, SENSE is set to +/- 1.
C
C     Adjust the longitude according to the sense of the body's
C     spin, or according to the override value if one is provided.
C     We want positive east longitude.
C
      GEOLON = SENSE * LON

C
C     Now that we have geodetic longitude in hand, use the
C     geodetic equivalent of the input coordinates to find the
C     Jacobian matrix of rectangular coordinates with respect
C     to geodetic coordinates.
C
      CALL DRDGEO ( GEOLON, LAT, ALT, RE, F, JACOBI )

C
C     The matrix JACOBI is
C
C        .-                              -.
C        |  DX/DGEOLON  DX/DLAT  DX/DALT  |
C        |  DY/DGEOLON  DY/DLAT  DY/DALT  |
C        |  DZ/DGEOLON  DZ/DLAT  DZ/DALT  |
C        `-                              -'
C
C     which, applying the chain rule to D(*)/DGEOLON, is equivalent to
C
C        .-                                       -.
C        |  (1/SENSE) * DX/DLON  DX/DLAT  DX/DALT  |
C        |  (1/SENSE) * DY/DLON  DY/DLAT  DY/DALT  |
C        |  (1/SENSE) * DZ/DLON  DZ/DLAT  DZ/DALT  |
C        `-                                       -'
C
C     So, multiplying the first column of JACOBI by SENSE gives us the
C     matrix we actually want to compute:  the Jacobian matrix of
C     rectangular coordinates with respect to planetographic
C     coordinates.
C
      DO I = 1, 3

         JACOBI(I,1) = SENSE * JACOBI(I,1)

      END DO

      CALL CHKOUT ( 'DRDPGR' )
      RETURN
      END


! Calculate power spectrum P(k) of a 1-D pencil array of data. The "overdensity" input array is any scalar field (not just density)
! in the form g(x) = (x/x_bar) - 1, where x_bar is the mean.

subroutine calc_ps1d (overdensity_fft_real, overdensity_fft_imag, lo, hi, ng, dir, num_bins, k_bin_edges, domain_length, &
                 k_bin_count, k_bin_power_weighted_k_sum, k_bin_power_sum)

  use, intrinsic :: iso_c_binding
  implicit none

  integer(c_int), intent(in) :: lo(3), hi(3), ng, num_bins, dir
  real(c_double), intent(in), target :: overdensity_fft_real (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in), target :: overdensity_fft_imag (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in) :: k_bin_edges (num_bins+1)
  real(c_double), intent(in) :: domain_length

  integer(c_int), intent(out) :: k_bin_count (num_bins)
  real(c_double), intent(out) :: k_bin_power_weighted_k_sum (num_bins)
  real(c_double), intent(out) :: k_bin_power_sum (num_bins)

  integer(c_int) :: i
  integer(c_int) :: k
  integer(c_int) :: k_bin_index
  integer(c_int) :: k_index

  real(c_double) :: k_fund
  real(c_double) :: k_mag
  real(c_double) :: k_max
  real(c_double) :: k_min
  real(c_double) :: k_nyquist
  real(c_double) :: p_i
  real(c_double) :: pi

  real(c_double), pointer :: overdensity_fft_real_pencil (:)
  real(c_double), pointer :: overdensity_fft_imag_pencil (:)

  complex(c_double_complex), allocatable :: overdensity_fft_pencil (:)

  pi = acos(-1.0)

  ! Align 1-D array pointers along pencils to simplify indexing later on.
  if (dir == 0) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1):hi(1), lo(2), lo(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1):hi(1), lo(2), lo(3), 1)
  else if (dir == 1) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1), lo(2):hi(2), lo(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1), lo(2):hi(2), lo(3), 1)
  else if (dir == 2) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1), lo(2), lo(3):hi(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1), lo(2), lo(3):hi(3), 1)
  end if

  allocate(overdensity_fft_pencil(size(overdensity_fft_real_pencil)))

  ! Combine the real and imaginary parts into a single complex array.
  do i = 1, size(overdensity_fft_pencil)
    overdensity_fft_pencil(i) = cmplx(overdensity_fft_real_pencil(i), overdensity_fft_imag_pencil(i), c_double_complex)
  end do

  k_fund = 2.0 * pi / domain_length

  k_nyquist = k_fund * size(overdensity_fft_pencil)/2

  k_min = minval(k_bin_edges)
  k_max = maxval(k_bin_edges)

  if (k_min < 0.0 .or. k_max > k_nyquist) then
    print *, "(k_min, k_max, k_nyquist) = ", k_min, k_max, k_nyquist
    stop 'spectral k values out of bounds'
  end if

  k_bin_count (:) = 0
  k_bin_power_weighted_k_sum (:) = 0.0
  k_bin_power_sum (:) = 0.0

  do i = lbound(overdensity_fft_pencil, 1), ubound(overdensity_fft_pencil, 1)
    if (i <= size(overdensity_fft_pencil)/2+1) then
      k_index = i-1
    else
      k_index = i-1 - size(overdensity_fft_pencil)
    end if

    if (k_index == 0) cycle

    k_mag = k_fund * real(abs(k_index), c_double)

    if (k_mag < k_min .or. k_mag >= k_max) cycle

    ! Find the k bin.
    k_bin_index = -1
    do k = 1, num_bins
    if (k_mag >= k_bin_edges(k) .and. k_mag < k_bin_edges(k+1)) then
        k_bin_index = k
          exit
      end if
    end do
    if (k_bin_index < 0) stop 'COULD NOT MATCH K BIN'

    p_i = (abs(overdensity_fft_pencil(i)))**2 / domain_length

    k_bin_count                (k_bin_index) = k_bin_count                (k_bin_index) + 1
    k_bin_power_weighted_k_sum (k_bin_index) = k_bin_power_weighted_k_sum (k_bin_index) + k_mag*p_i
    k_bin_power_sum            (k_bin_index) = k_bin_power_sum            (k_bin_index) + p_i

  end do

  deallocate(overdensity_fft_pencil)

end subroutine calc_ps1d


program ComputeGammaInt

  implicit none

  integer :: i

  write(*, "(3A15)") "Simpson", "Lanczos", "Builtin"
  do i=1, 10
     write(*, "(3F15.8)") my_gamma(i/3.0), lacz_gamma(i/3.0), gamma(i/3.0)
  end do

contains

  pure function intfuncgamma(x, y) result(z)
    real :: z
    real, intent(in) :: x, y

    z = x**(y-1.0) * exp(-x)
  end function intfuncgamma

  function my_gamma(a) result(g)
    real :: g
    real, intent(in) :: a

    real, parameter :: small = 1.0e-4
    integer, parameter :: points = 100000

    real :: infty, dx, p, sp(2, points), x
    integer :: i
    logical :: correction

    x = a

    correction = .false.
    ! value with x<1 gives \infty, so we use
    ! \Gamma(x+1) = x\Gamma(x)
    ! to avoid the problem
    if ( x < 1.0 ) then
       correction = .true.
       x = x + 1
    end if

    ! find a "reasonable" infinity...
    ! we compute this integral indeed
    ! \int_0^M dt t^{x-1} e^{-t}
    ! where M is such that M^{x-1} e^{-M} ≤ \epsilon
    infty = 1.0e4
    do while ( intfuncgamma(infty, x) > small )
       infty = infty * 10.0
    end do

    ! using simpson
    dx = infty/real(points)
    sp = 0.0
    forall(i=1:points/2-1) sp(1, 2*i) = intfuncgamma(2.0*(i)*dx, x)
    forall(i=1:points/2) sp(2, 2*i - 1) = intfuncgamma((2.0*(i)-1.0)*dx, x)
    g = (intfuncgamma(0.0, x) + 2.0*sum(sp(1,:)) + 4.0*sum(sp(2,:)) + &
         intfuncgamma(infty, x))*dx/3.0

    if ( correction ) g = g/a

  end function my_gamma

  recursive function lacz_gamma(a) result(g)
    real, intent(in) :: a
    real :: g

    real, parameter :: pi = 3.14159265358979324
    integer, parameter :: cg = 7

    ! these precomputed values are taken by the sample code in Wikipedia,
    ! and the sample itself takes them from the GNU Scientific Library
    real, dimension(0:8), parameter :: p = &
         (/ 0.99999999999980993, 676.5203681218851, -1259.1392167224028, &
         771.32342877765313, -176.61502916214059, 12.507343278686905, &
         -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7 /)

    real :: t, w, x
    integer :: i

    x = a

    if ( x < 0.5 ) then
       g = pi / ( sin(pi*x) * lacz_gamma(1.0-x) )
    else
       x = x - 1.0
       t = p(0)
       do i=1, cg+2
          t = t + p(i)/(x+real(i))
       end do
       w = x + real(cg) + 0.5
       g = sqrt(2.0*pi) * w**(x+0.5) * exp(-w) * t
    end if
  end function lacz_gamma

end program ComputeGammaInt


      SUBROUTINE DRFVAL (X, Y, Z, RF, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 DRFVAL Krogh  Moved external statement up for mangle.
C>>   1995-11-17 DRFVAL Krogh  Converted SFTRAN to Fortran 77.
c>>   1994-11-02 DRFVAL Krogh  Changes to use M77CON
c>>   1994-08-15 DRFVAL WV Snyder JPL use 2-arg min and max for C conv.
c>>   1993-02-23 DRFVAL WV Snyder JPL Split DRFVLX into a separate subr.
C>>   1991-10-31 DRFVAL WV Snyder JPL Incorporate changes from Carlson
C>>   1990-11-27 DRFVAL WV Snyder JPL Convert Carlson's code for MATH77
C
C--D replaces "?": ?ERM1, ?ERV1, ?RFVAL, ?RFVLX
C
C     CHECK ARGUMENT RANGES AND CALL DRFVLX TO DO THE COMPUTATION
C     OF CARLSON'S ELLIPTIC INTEGRAL RF(X,Y,Z).
C
C     INPUT ...
C
C     X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C     OUTPUT ...
C
C     RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C     IERR IS THE RETURN ERROR CODE.
C          IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C          IERR = 1  X, Y, OR Z IS NEGATIVE.
C          IERR = 2  X+Y, X+Z, OR Y+Z IS TOO SMALL.
C          IERR = 3  X, Y, OR Z IS TOO LARGE.
C
      DOUBLE PRECISION X, Y, Z, RF
      INTEGER IERR
C ----------------------------------------------------------------------
      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH
C ----------------------------------------------------------------------
C
C     MACHINE DEPENDENT PARAMETERS ...
C
C     LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C     LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C     UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
      DOUBLE PRECISION LOLIM, UPLIM
      SAVE LOLIM, UPLIM
      DATA LOLIM /-1.0d0/
C ----------------------------------------------------------------------
C     WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C     EXPENSE OF ROBUSTNESS.
C ----------------------------------------------------------------------
C
      RF = 0.0d0
      IF (MIN(X,MIN(Y,Z)) .LT. 0.0d0) THEN
         IERR = 1
         CALL DERM1 ('DRFVAL',1,0,'One of X, Y or Z is negative','X',x,
     1     ',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,'.')
         RETURN
      END IF
      IF (LOLIM .LT. 0.0d0) THEN
         LOLIM = 5.0d0 * D1MACH(1)
         UPLIM = D1MACH(2) / 5.0d0
      END IF
      IF (MAX(X,MAX(Y,Z)) .GT. UPLIM) THEN
         IERR = 3
         CALL DERM1 ('DRFVAL',3,0,'One of X, Y or Z > UPLIM','X',
     1     x,',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,',')
         CALL DERV1 ('UPLIM',UPLIM,'.')
         RETURN
      END IF
      IF (MIN(X+Y,MIN(X+Z,Y+Z)) .LT. LOLIM) THEN
         IERR = 2
         CALL DERM1 ('DRFVAL',2,0,'One of X+Y, X+Z or Y+Z < LOLIM','X',
     1     x,',')
         CALL DERV1 ('Y',Y,',')
         CALL DERV1 ('Z',Z,',')
         CALL DERV1 ('LOLIM',LOLIM,'.')
         RETURN
      END IF
C
      IERR = 0
      CALL DRFVLX (X, Y, Z, RF)
      RETURN
      END

      SUBROUTINE DRFVLX (X, Y, Z, RF)
c>>   1993-02-23 DRFVLX WV Snyder JPL Split DRFVLX into a separate subr.
C     ------------------------------------------------------------------
C     DRFVLX SHOULD ONLY BE CALLED FROM OTHER LIBRARY ROUTINES, WHERE WE
C     KNOW X, Y, Z ARE IN RANGE.  USERS SHOULD NOT CALL DRFVLX DIRECTLY.
C     ------------------------------------------------------------------
C
C     COMPUTE THE INCOMPLETE ELLIPTIC INTEGRAL OF THE FIRST KIND
C
C     RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                           -1/2     -1/2     -1/2
C                 (1/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C     WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM
C     IS ZERO.  IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE.
C     THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C     NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C     SERIES TO FIFTH ORDER.
C     REFERENCES: B. C. CARLSON AND E. M. NOTIS, ALGORITHMS FOR
C     INCOMPLETE ELLIPTIC INTEGRALS, ACM TRANSACTIONS ON MATHEMA-
C     TICAL SOFTWARE, 7 (1981), 398-403; B. C. CARLSON, COMPUTING
C     ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH., 33 (1979),
C     1-16.
C     AUTHORS: B. C. CARLSON AND ELAINE M. NOTIS, AMES LABORATORY-
C     DOE, IOWA STATE UNIVERSITY, AMES, IA 50011, AND R. L. PEXTON,
C     LAWRENCE LIVERMORE NATIONAL LABORATORY, LIVERMORE, CA 94550.
C     AUG. 1, 1979, REVISED JAN. 15, 1987.
C
C     CHECK VALUE: RF(0,1,2) = 1.31102 87771 46059 90523 24198
C     CHECK BY ADDITION THEOREM: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W)
C     = RF(0,Z,W), WHERE X,Y,Z,W ARE POSITIVE AND X * Y = Z * W.
C
      DOUBLE PRECISION X, Y, Z, RF
C     INPUT ...
C
C     X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C     OUTPUT ...
C
C     RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C ----------------------------------------------------------------------
      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH
      DOUBLE PRECISION C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA
      DOUBLE PRECISION MU,S,XN,XNDEV,XNROOT
      DOUBLE PRECISION YN,YNDEV,YNROOT,ZN,ZNDEV,ZNROOT
      PARAMETER (C1 = 10.0d0 / 24.0d0)
      PARAMETER (C2 = 30.0d0 / 44.0d0)
      PARAMETER (C3 = 10.0d0 / 14.0d0)
C ----------------------------------------------------------------------
C     MACHINE DEPENDENT PARAMETER ...
C     ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C     RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C     ERRTOL ** 6 / (4 * (1 - ERRTOL)).
C
      SAVE ERRTOL
      DATA ERRTOL /-1.0D0/
C ----------------------------------------------------------------------
      IF (ERRTOL .LT. 0.0d0) ERRTOL = (3.6d0 * D1MACH(4))**(1.0d0/6.0d0)
      XN = X
      YN = Y
      ZN = Z
C
   20 CONTINUE
         MU = (XN + YN + ZN) / 3.0d0
         XNDEV = 2.0d0 - (MU + XN) / MU
         YNDEV = 2.0d0 - (MU + YN) / MU
         ZNDEV = 2.0d0 - (MU + ZN) / MU
         EPSLON = MAX(ABS(XNDEV),MAX(ABS(YNDEV),ABS(ZNDEV)))
         IF (EPSLON .LT. ERRTOL) THEN
            E3 = XNDEV * YNDEV
            E2 = E3 - ZNDEV * ZNDEV
            E3 = E3 * ZNDEV
            S = 10.0d0 + (C1 * E2 - 1.0d0 - C2 * E3) * E2 + C3 * E3
            RF = S / (10.0d0*SQRT(MU))
            RETURN
         END IF
         XNROOT = SQRT(XN)
         YNROOT = SQRT(YN)
         ZNROOT = SQRT(ZN)
         LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
         XN = (XN + LAMDA) * 0.25d0
         YN = (YN + LAMDA) * 0.25d0
         ZN = (ZN + LAMDA) * 0.25d0
      GO TO 20
      END


      SUBROUTINE DTGGRD(X,Y,NP,IP,W,TRIANG,MT,B,MB,NT,INFO)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c  File: dtggrd.[f|for]
c  contains dtggrd, dtgang, dtgadj, dtgupd
c
c>> 1997-07-01 DTGGRD Krogh Reversed subscripts in B (CLL suggestion)
c>> 1997-06-14 DTGGRD Krogh Removed implicit none, added external stmt.
c>> 1997-06-14 DTGGRD CLL Argument INFO() replaces NBUSED, MODE, & OK1.
C>> 1997-06-09 DTGGRD  Krogh  Converted SFTRAN code to Fortran.
C>> 1995-09-26 DTGGRD CLL Editing for inclusion into MATH77.
c>> 1991-11-20 DTGGRD CLL Using Math77 subroutine _SORTP for sorting.
C
C         THIS SUBR CONSTRUCTS A LIST OF POINTERS IN THE ARRAY
C    TRIANG() DEFINING A TRIANGULAR GRID HAVING THE GIVEN (X,Y)
C    DATA AS VERTICES.
C         THE GRID WILL BE OPTIMAL IN THE SENSE OF THE MAX-MIN ANGLE
C    CRITERION.  IT HAS BEEN SHOWN, INDEPENDENTLY BY LAWSON AND BY
C    R. SIBSON, THAT THIS IS EQUIVALENT TO SOME OTHER OPTIMALLITY
C    CRITERIA.  THE GRID PRODUCED IS A DELAUNAY TRIANGULATION AND
C    IS THE GRAPH THEORETIC DUAL OF A TESSELLATION MADE UP OF
C    PROXIMITY REGIONS ASSOCIATED WITH THE NAMES DIRICHLET,
C    VORONOI, AND THIESSEN.
C
C    C. L. LAWSON, JPL, 1976 NOV 28
C     C.L.L., 1979 MAR 3. CONVERTED TO SFTRAN3.
C     C.L.L., 1979 JUL 22. ADDED CALL TO DTGSIZ.
C
C  X(1:NP),Y(1:NP) [in]    (X,Y) DATA POINTS.
C  NP [in]                    NO. OF DATA POINTS.  REQUIRE NP .GE. 3.
C
C  IP() [scratch]   WORK SPACE OF LENGTH at least NP.
C  W()  [scratch]   WORK SPACE OF LENGTH at least NP.
C  TRIANG() [out]  ARRAY IN WHICH THIS SUBR WILL BUILD A LIST DEFINING
C             A triangular grid.  access to this list is via the
C             four subrs DTGGET, DTGPUT, DTGSIZ, and DTGSET.
C  MT [in]   DIMENSION OF ARRAY TRIANG().  NO. OF TRIANGLES IT
C            CAN HOLD, NTLIM, IS DETERMINED BY USE OF SUBROUTINE
C            DTGSIZ.    NTLIM WILL BE MT/6 IF POINTERS ARE NOT
C            PACKED.  NTLIM = (3*MT)/6 IF POINTERS ARE PACKED
C            THREE PER WORD.
c  Bdry(1:4, MB) [integer, out]  Array containing pointers defining the
c      boundary of the (convex) triangular grid.
C         Bdry(1, K) = FWD POINTER. Points to next vertex in
c                     counterclockwise order.
C         Bdry(2, K) = BACKWARD POINTER. Points to next vertex in
c                     clockwise order.
C         Bdry(3, K) = A BOUNDARY POINT
C         Bdry(4, K) = A BOUNDARY TRIANGLE
c      The triangle Bdry(4, K) has a boundary edge that
c      connects the points Bdry(3, K) and Bdry(3, K+1).
c
c      On return from this subroutine, some elements of the array Bdry()
c      may not be members of the linked list defining the boundary. The
c      entry with K = 1 will always be a member of the boundary list.
c      Thus for another subroutine to scan the Bdry() list made by this
c      subroutine it should start with K = 1 and follow the forward or
c      backward pointers.
c
C  MB [in]   FIRST DIMENSION OF B(,).  SETTING MB = NP+1 WILL
C            ALWAYS BE ADEQUATE, HOWEVER A MUCH SMALLER VALUE
C            WILL OFTEN SUFFICE.  SUGGEST TRYING MB = 6 * (cube root
C            of NP) WHEN NP .GE. 64.
C  NT [out]  OUTPUT..  NO. OF TRIANGLES
c
c  INFO(1:3) [out, integer]  Termination status information.
c
c     INFO(1) INDICATES STATUS ON TERMINATION.
C              0  NORMAL TERMINATION.  The triangular grid is complete
c                 and successfully optimized.
C              1  ERROR. The triangular grid is complete but not
c                 successfully optimized.  Apparent looping in DTGADJ.
C                 GRID MAY NOT BE OPTIMAL.
C              2  ERROR.  ALL GIVEN POINTS ARE COLINEAR.  NO TRIANGLES
C                 CONSTRUCTED.  (OR ELSE THERE ARE SOME DUPLICATE PTS)
C              3  ERROR.  DUPLICATE POINTS.  TRIANGULAR GRID NOT
C                 COMPLETED.
C              4  ERROR.  NOT ENOUGH SPACE IN B(,).  USER MUST
C                 INCREASE MB.
C              5  NOT ENOUGH SPACE IN TRIANG().  USER MUST MAKE
C                 MT BIGGER.
C     INFO(2)  NO. OF BOUNDARY POINTS.
C     INFO(3)  SMALLEST SETTING OF MB THAT WOULD SUFFICE FOR THIS DATA.
c
c        [Relations to internal variables or previously used variable
c         names:  INFO(1) = MODE, INFO(2) = NB, INFO(3) = MBUSED,
c         The value of INFO(1) = MODE will be  set to 0 when
c         OK1 = .true. and 1 when OK1 = .false.]
C
C                  USE SUBR DTGSIZ TO COMPUTE NTLIM, THE MAX NO. OF
C                 TRIANGLES, GIVEN THE DIMENSION PARAMETER MT.
C
c     ------------------------------------------------------------------
c--D replaces "?": ?TGGRD, ?TGANG, ?TGSET, ?TGGET, ?TGPUT, ?TGSIZ,
c--&               ?TGADJ, ?SORTP, ?TGUPD
c     ------------------------------------------------------------------
      INTEGER NP, mb, mt
      INTEGER AVAIL, B(4, MB), ext, TRI(6)
      integer i, i1, i2, i3, i3prev, index, INFO(3), ip(np), isave
      integer jhi, jlo, jnew
      integer k, kb1, kbhi, kblo, kbnew, kbz
      integer mode
      integer nb, nt, ntlim, mbused,  TRIANG(MT)
      double precision aref, cross
      external DTGANG
      double precision DTGANG
      double precision dx12, dy12, eight, pangle
      DOUBLE PRECISION W(np), X(NP), xmean, Y(NP), ymean, zero
        parameter(zero = 0.0d0, eight = 8.0d0)
      LOGICAL  OK, OK1
c     ------------------------------------------------------------------
      call DTGSIZ( MT, NTLIM )
      MODE = 0
      OK1 = .TRUE.
C
C        FIND AN EXTREME POINT (X(EXT),Y(EXT))
C
      EXT=1
      do 10 I = 1, NP
         if ( X(I) .lt. X(EXT)
     *     .or. (X(I) .eq. X(EXT)  .and.  Y(I) .lt. Y(EXT) )) EXT=I
   10 continue
C
C             COMPUTE SQUARED DISTANCES FROM (X(EXT),Y(EXT)).
C             ALSO INITIALIZE IP().
      do 20 I = 1, NP
         W(I) = (X(I)-X(EXT))**2 + (Y(I)-Y(EXT))**2
   20 continue
c
c        Use _SORTP from the JPL MATH77 library to
c        determine a sorted order for the contents of W() and set
c        indices indicating the sorted order in IP().
c        IP() will be set so that W(IP(1)) is the smallest number in
c        W(), W(IP(2)) is the next larger number, etc.  The contents
c        of IP() will be used as indices into the X() and Y() arrays.
c        The contents of W() will not be reordered by _SORTP, however
c        this does not matter here since the next time we reference W()
c        will be to store other things into it.
c
      call DSORTP(W, 1, NP, IP)
C
C             BUILD THE FIRST TRIANGLE USING POINTS IP(1), IP(2), AND
C             THE NEXT POINT THAT IS NOT COLINEAR WITH THESE TWO.
C
      I1=IP(1)
      I2=IP(2)
      DX12= X(I2)-X(I1)
      DY12= Y(I2)-Y(I1)
      I3PREV = 0
      do 40 I = 3, NP
         I3 = IP(I)
         IP(I) = I3PREV
         CROSS =-(X(I3)-X(I2))*DY12 + (Y(I3)-Y(I2))*DX12
         if (CROSS .ne. 0.) then
            if (CROSS .lt. 0.) then
C                                 SWAP I2 AND I3
               ISAVE=I2
               I2   =I3
               I3   =ISAVE
            end if
            go to 50
         end if
         I3PREV=I3
   40 continue
C
C             ERROR IF DROP THRU TO HERE.  ALL NP POINTS ARE COLINEAR
C             OR ELSE POINTS I1 AND I2 ARE IDENTICAL.
C
      MODE = 2
      go to 999
C
C
   50 continue
C                  HERE THE VERTICES OF THE FIRST TRIANGLE ARE I1,I2,I3
C
C                  COMPUTE MEAN OF VERTICES OF FIRST TRIANGLE.
C
      XMEAN = (X(I1)+X(I2)+X(I3))/3.
      YMEAN = (Y(I1)+Y(I2)+Y(I3))/3.
C
C             COMPUTE THE PSEUDOANGLE OF VECTOR FROM (XMEAN,YMEAN)
C             TO I1.
C
      AREF = DTGANG(X(I1)-XMEAN, Y(I1)-YMEAN, zero)
C
C        INITIALIZE BOUNDARY POINTER STRUCTURE B(,).
C        B(1, K) = FWD POINTER
C        B(2, K) = BACKWARD POINTER
C        B(3, K) = A BOUNDARY POINT
C        B(4, K) = A BOUNDARY TRIANGLE
C        W(K)   = PSEUDOANGLE OF POINT B(3, K)
C
      do 70 K = 1, MB
         B(1, K) = K+1
   70 continue
      B(1, MB) = 0
      B(1, 4)  = 0
      AVAIL   = 5
      do 80 K = 1, 4
         B(2, K) = K-1
         B(4, K) = 1
   80 continue
      B(4, 4) = 0
C
      B(3, 1) = I1
      B(3, 2) = I2
      B(3, 3) = I3
      B(3, 4) = I1
C
      W(1) = zero
      W(2) = DTGANG(X(I2)-XMEAN,Y(I2)-YMEAN,AREF)
      W(3) = DTGANG(X(I3)-XMEAN,Y(I3)-YMEAN,AREF)
      W(4) = eight
      NB = 3
      MBUSED = 3
C
C                  BUILD FIRST TRIANGLE IN TRIANG().
C
      if (NTLIM .le. 0) then
         MODE = 5
         go to 999
      end if
      call DTGSET(1,0,0,0,I1,I2,I3,TRIANG,MT)
      NT=1
C    ******************************************************************
C
C                  BEGIN MAIN LOOP.  ADD ONE NEW POINT AT A TIME INTO
C                  THE TRIANGULAR GRID STRUCTURE.
C
C    ******************************************************************
      KBNEW=2
      do 200 INDEX = 4, NP
         JNEW = IP(INDEX)
         PANGLE = DTGANG(X(JNEW)-XMEAN, Y(JNEW)-YMEAN, AREF)
C
C                  USE  PANGLE  AS SEARCH KEY IN THE TABLE OF
C                  PSEUDO ANGLES OF BOUNDARY POINTS.
C                  START SEARCH AT PREVIOUS NEW BOUNDARY POINT.
C
         KB1= KBNEW
         if ( PANGLE .gt. W(KB1)) then
            KBHI = KB1
  100       KBLO = KBHI
            KBHI = B(1, KBLO)
            if ( PANGLE .gt. W(KBHI) ) go to 100
         else
C                            HERE WE HAVE  PANGLE .le. W(KB1)
            KBLO = KB1
  110       KBHI = KBLO
            KBLO = B(2, KBHI)
            if ( PANGLE .lt. W(KBLO) ) go to 110
         end if
C
         JLO = B(3, KBLO)
         JHI = B(3, KBHI)
C
C                            TEST FOR DUPLICATE POINTS
C
         if ( PANGLE .eq. W(KBLO) ) then
            if ( X(JNEW) .eq. X(JLO) .and. Y(JNEW).eq.Y(JLO)) then
               MODE = 3
               go to 999
            end if
         else if (PANGLE .eq. W(KBHI) ) then
            if (X(JNEW).eq.X(JHI) .and. Y(JNEW).eq.Y(JHI)) then
               MODE = 3
               go to 999
            end if
         end if
C
C                            Attach point JNEW to JHI and JLOW.
         if (AVAIL .eq. 0) then
C                                 ERROR..  INSUFFICIENT STORAGE IN B()
C                                 TO REPRESENT THE BOUNDARY.
            MODE = 4
              go to 999
           endif
         if (NT   .ge. NTLIM) then
C                                 ERROR..  INSUFFICIENT STORAGE IN
C                                 TRIANG()
            MODE=5
            go to 999
         endif
C                                 UPDATE TRIANG().
            NT=NT+1
            call DTGUPD(B(3, KBLO), B(4, KBLO), TRI, TRIANG, MT, NT)
            call DTGSET(NT,B(4, KBLO),0,0,JHI,JLO,JNEW,TRIANG,MT)
C
C                                 UPDATE B() AND W().
            NB = NB+1
            if (NB .gt. MBUSED) MBUSED = NB
            KBNEW = AVAIL
            AVAIL = B(1, AVAIL)
            B(1, KBNEW) = KBHI
            B(2, KBNEW) = KBLO
            B(3, KBNEW) = JNEW
            B(4, KBNEW) = NT
            W(KBNEW)   = PANGLE
            B(1, KBLO)  = KBNEW
            B(2, KBHI)  = KBNEW
            B(4, KBLO)  = NT
C
            call DTGADJ(NT,1,X,Y,NP,TRIANG,MT,B,MB, KBNEW, OK)
            OK1 = OK1 .and. OK

C  Done attaching point JNEW to JHI and JLOW.
C  We have just assigned JNEW the index KBNEW in the boundary list.
C
C             LOOP BACKWARD ALONG BOUNDARY FROM KBNEW TO FIND OTHER
C             POINTS TO WHICH POINT JNEW CAN BE CONNECTED.
C
         KBHI= KBLO
         KBLO = B(2, KBHI)
  130    if (KBLO .ne. 0) then
            JHI = B(3, KBHI)
            JLO = B(3, KBLO)
            CROSS = -(Y(JHI)-Y(JNEW)) * (X(JLO)-X(JHI))
     *              +(X(JHI)-X(JNEW)) * (Y(JLO)-Y(JHI))
            if (CROSS .gt. 0.) then
C                  CONNECT POINT JNEW TO JLO
               if (NT .ge. NTLIM) then
C                    ERROR..  INSUFFICIENT SPACE IN TRIANG().
C
                  MODE=5
                    go to 999
               endif
C                              UPDATE TRIANG()
                  NT=NT+1
                  call DTGUPD(B(3,KBLO), B(4,KBLO), TRI, TRIANG, MT, NT)
                  call DTGUPD(B(3,KBHI), B(4,KBHI), TRI, TRIANG, MT, NT)
                  call DTGSET(NT, B(4, KBLO), 0, B(4, KBHI), JHI, JLO,
     1               JNEW, TRIANG, MT)
C
C                              UPDATE B()
                  B(1, KBLO) = KBNEW
                  B(2, KBNEW)= KBLO
                  B(4, KBLO) = NT
                  NB=NB-1
                  B(1, KBHI) = AVAIL
                  AVAIL     = KBHI
C
                  call DTGADJ(NT,1,X,Y,NP,TRIANG,MT,B,MB, KBNEW, OK)
                  OK1 = OK1 .and. OK
c                     Done connecting point JNEW to JLO
c
                  KBHI = KBLO
                  KBLO = B(2, KBHI)
                  go to 130

            end if
         end if
C
C          LOOP FORWARD ALONG BOUNDARY FROM KBNEW TO FIND OTHER
C          POINTS TO WHICH POINT JNEW CAN BE CONNECTED.
C
         KBLO = B(1, KBNEW)
         KBHI = B(1, KBLO)
  150    if (KBHI.ne.0) then
            JHI= B(3, KBHI)
            JLO= B(3, KBLO)
            CROSS = -(Y(JLO)-Y(JHI)) * (X(JNEW)-X(JLO))
     *         +(X(JLO)-X(JHI)) * (Y(JNEW)-Y(JLO))
            if (CROSS .gt. 0) then
               if (NT .ge. NTLIM) then
C                       ERROR..  INSUFFICIENT SPACE IN TRIANG().
                  MODE = 5
                    go to 999
               endif
C          Connect point JNEW to JHI -- Update TRIANG()
                  NT=NT+1
                  call DTGUPD(B(3, KBLO),B(4, KBLO),TRI,TRIANG,MT,NT)
                  call DTGUPD(B(3, KBNEW),B(4, KBNEW),TRI,TRIANG,MT,NT)
                  call DTGSET(NT, B(4, KBLO), B(4, KBNEW), 0, JHI, JLO,
     1               JNEW, TRIANG, MT)
C
C                                 UPDATE B()
                  B(1, KBNEW) = KBHI
                  B(2, KBHI)  = KBNEW
                  B(4, KBNEW) = NT
                  NB=NB-1
                  B(1, KBLO)  = AVAIL
                  AVAIL      = KBLO
C
                  call DTGADJ(NT,1,X,Y,NP,TRIANG,MT,B,MB, KBNEW, OK)
                  OK1 = OK1 .and. OK
C                                 Done connecting point JNEW to JHI
c
                  KBLO = KBHI
                  KBHI = B(1, KBLO)
                  go to 150

            end if
         end if
  200 continue
      MBUSED = MBUSED + 1
C
  999 continue
c
c        As built, the linked boundary list runs (counterclockwise) from
c        b(*, 1) to b(*, 4), with b(*, 1) and b(*, 4) representing the
c        same point.  The back pointer in b(*, 1) and the forward
c        pointer in b(*, 4) are both zero, indicating ends of the list.
c        Change this so the linked list is fully circular, still
c        including b(*, 1), but detaching b(*, 4).  Let kbz be the value
c        of the back pointer in b(*, 4).  Set the back pointer in b(*,
c        1) to be kbz, and the forward pointer in b(*, kbz) to be 1.
c
      kbz = b(2, 4)
      b(2, 1) = kbz
      b(1, kbz) = 1

      if(MODE .eq. 0 .and. .not. OK1) MODE = 1
      INFO(1) = MODE
      INFO(2) = NB
      INFO(3) = MBUSED
      end
c     ==================================================================

      subroutine DTGUPD( JFIX, KB4, TRI, TRIANG, MT, NT)
c               Updates TRIANG, using JFIX and KB4
      integer JFIX, KB4, MT, NT, TRI(6), TRIANG(MT)
      integer I
c
      call DTGGET(KB4,TRI,TRIANG)
      do 10 I = 1, 3
         if (TRI(I+3) .eq. JFIX) then
            TRI(I) = NT
            go to 20
         end if
   10 continue
   20 call DTGPUT(KB4, TRI, TRIANG, MT)
      return
      end
c     ==================================================================
      DOUBLE PRECISION FUNCTION DTGANG  (XX,YY,AREF)
C>> 1995-09-26 CLL Editing for inclusion into MATH77.
C
c     Compute the pseudoangle  DTGANG  between the reference direction
c     whose pseudoangle is  AREF  and the vector  (XX,YY).
c     Pseudoangle is measured counterclockwise with period 8.
c     Require  0. .le. AREF .lt. 8. on input.
c     On return DTGANG will be in the interval 0. .le. DTGANG .lt. 8.
C
c     C.L.LAWSON, JPL, 1976 NOV 8
C
c     ------------------------------------------------------------------
      double precision xx,yy,aref,a
      double precision eight, four, two, zero
      parameter(eight = 8.0d0, four = 4.0d0, two = 2.0d0, zero = 0.0d0)
c     ------------------------------------------------------------------
      if (abs(xx) .gt. abs(yy)) then
         a = yy/xx
         if (xx .lt. zero) then
            a=a+four
         else
            if (yy .lt. zero) then
               a=a+ eight
            end if
         end if
      else
         if (yy .eq. zero) then
            a = zero
         else
            a = two - xx/yy
            if (yy .lt. zero) a = a+four
         end if
      end if
c     .                            A IS NOW THE PSEUDOANGLE OF (XX,YY)
c     .                            RELATIVE TO (1.,0.) AND LYING IN
c     .                            THE INTERVAL   0. .le. A .lt. 8.
      dtgang = a - aref
      if (dtgang .lt. zero) dtgang = dtgang + eight
      return
      end
c     ==================================================================
      SUBROUTINE DTGADJ(TIN,NIN,X,Y,NP,TRIANG,MT,B,MB,KBNEW, OK)
C>> 1995-09-26 CLL Editing for inclusion into MATH77.
C
C     C.L.LAWSON, JPL, 1976 NOV 30, Changed 1977 APR 7
C     Changed 1977 June 16 to get rid of internal arrays
c     used to stack triangles to be tested.
c
c     Given triangle TIN and the neighboring triangle that is in
c     position NIN relative to TIN,  Test for possible exchange of
c     their common edge.
c     Use the criterion of maximizing the smallest angle, which is the
c     same as the criterion of the empty circumcircle.
c     If the swap is made then certain other edges must be tested.
c     This subr does the tests, swaps edges as needed, and does
c     tests and swaps on other edges as needed.
c     The counter COUNT is used to guard against infinite looping
c     which should never happen anyway.  If count exceeds 100 the
c     subr sets OK = .false. indicating that the triangulation
c     produced may not be optimal.
c     ------------------------------------------------------------------
C                       Subroutine Arguments
c
c  TIN [integer, in]
c  NIN [integer, in]
c  X(),Y() [floating, in]
c  TRIANG() [integer, inout]
c  MT [integer, in]
c  B(1:4, ) [integer, inout]
c  MB [integer, in]
c  KBNEW [integer, in]  Index into the boundary array, B(,).
c  OK [logical, out]
c     ------------------------------------------------------------------
      integer mb
      INTEGER  ADD1(3)
      INTEGER  B(4, MB), COUNT
      integer i, k, kbkwd,KBNEW, kfwd
      integer more, mt
      integer nabor1, nabor2, nin, np
      INTEGER  QV1,QV2,QV3,QV4,QV1S(3),QV2S(3),QV3S(3),SUB1(3)
      INTEGER  t1, T11,T12,t2, T21,T22, tin
      INTEGER  TNEW, TOLD, TRI1(6),TRI2(6), TRIANG(MT)
      double precision a123, a234, a341, a412
      double precision diag13, diag24
      double precision dx12, dx23, dx34, dx41, dy12, dy23, dy34, dy41
      double precision s12, s23, s34, s41
      double precision tau13, tau24
      DOUBLE PRECISION X(NP),Y(NP)
      LOGICAL  OK, SWAP
      DATA QV1S(1),QV1S(2),QV1S(3)/ 5, 6, 4/
      DATA QV2S(1),QV2S(2),QV2S(3)/ 6, 4, 5/
      DATA QV3S(1),QV3S(2),QV3S(3)/ 4, 5, 6/
      DATA ADD1(1),ADD1(2),ADD1(3)/ 2, 3, 1/
      DATA SUB1(1),SUB1(2),SUB1(3)/ 3, 1, 2/
c     ------------------------------------------------------------------
      T1=TIN
      NABOR1 = NIN
      COUNT = 1
      MORE = 1
      OK = .TRUE.
   20 if ((MORE .gt. 0) .and. OK) then

         call DTGGET(T1,TRI1,TRIANG)
         T2 = TRI1(NABOR1)
         if ( T2 .ne. 0) then
C T2=0 MEANS SIDE NABOR OF TRIANGLE T1 IS A BOUNDARY EDGE SO THERE IS NO
C TRIANGLE T2.  HERE WE HAVE  T2 .ne. 0
            call DTGGET(T2,TRI2,TRIANG)
C  SET QV1,...,QV4 AS INDICES OF THE 4 VERTICES OF THE QUADRILATERAL
C  FORMED BY THE 2 TRIANGLES T1 AND T2
            I=QV1S(NABOR1)
            QV1=TRI1(I)
            I=QV2S(NABOR1)
            QV2=TRI1(I)
            I=QV3S(NABOR1)
            QV3=TRI1(I)
            do 40 NABOR2 = 1, 3
               if (TRI2(NABOR2) .eq. T1) then
                  I=QV2S(NABOR2)
                  QV4=TRI2(I)
                  go to 50
               end if
   40       continue
   50       continue

C The max-min angle test below is made using the max-min angle criterion
c as described in JPL internal TECH.  MEMO.  914-299, FEB., 1972 by
c C. L.  LAWSON.
C
            DX23 = X(QV3)-X(QV2)
            DY23 = Y(QV3)-Y(QV2)
            DX34 = X(QV4)-X(QV3)
            DY34 = Y(QV4)-Y(QV3)
            A234 = DX23*DY34 - DY23*DX34
            if (A234 .le. 0.) then
               SWAP = .FALSE.
            else
               DX12 = X(QV2)-X(QV1)
               DY12 = Y(QV2)-Y(QV1)
               DX41 = X(QV1)-X(QV4)
               DY41 = Y(QV1)-Y(QV4)
               A412 = DX41*DY12 - DY41*DX12
               if (A412 .le. 0.) then
                  SWAP = .FALSE.
               else
                  A341 = DX34*DY41 - DY34*DX41
                  A123 = A234 + A412 - A341
                  S12 = DX12**2 + DY12**2
                  S23 = DX23**2 + DY23**2
                  S34 = DX34**2 + DY34**2
                  S41 = DX41**2 + DY41**2
                  DIAG13 = (X(QV3)-X(QV1))**2 + (Y(QV3)-Y(QV1))**2
                  DIAG24 = (X(QV4)-X(QV2))**2 + (Y(QV4)-Y(QV2))**2
                  TAU13 = min( A123**2 / max(S12,S23),
     *               A341**2 / max(S34,S41)) / DIAG13
                  TAU24 = min( A234**2 / max(S23,S34),
     *               A412**2 / max(S41,S12)) / DIAG24
                  SWAP = TAU24 .gt. TAU13
               end if
            end if
c End of max-min angle test
         else
            SWAP = .FALSE.
         end if
         if ( SWAP) then
c  Remove the edge connecting QV1 and QV3.  Insert new edge connecting
C  QV2 and QV4.  Redefine triangle T1 to have vertices QV1, QV2, and
C  QV4.  Redefine triangle T2 to have vertices QV2, QV3, AND QV4.
            I = ADD1(NABOR1)
            T11 = TRI1(I)
            I = ADD1(I)
            T12 = TRI1(I)
C
            I   = ADD1(NABOR2)
            T21 = TRI2(I)
            I   = ADD1(I)
            T22 = TRI2(I)
C
            call DTGSET(T1,T11,T2,T22,QV1,QV2,QV4,TRIANG,MT)
            call DTGSET(T2,T12,T21,T1,QV2,QV3,QV4,TRIANG,MT)
C
            TNEW=T2
            if ( T12 .ne. 0) then
               call DTGGET( T12,TRI2, TRIANG)
               do 70 I = 1, 3
                  if (TRI2(I) .eq. T1) then
                     TRI2(I) = TNEW
                     go to 80
                  end if
   70          continue
   80          call DTGPUT( T12,TRI2, TRIANG, MT)
            else
C The following test of (QV2 .eq.  B(3, KBNEW)) will always be true if
C the outer algorithm calling this subroutine is the one originally
C planned, always adding new points from the exterior, not from the
C interior.  The false branch is provided to handle the more general
c case.
               if (QV2 .eq. B(3, KBNEW) ) then
                  B(4, KBNEW) = TNEW
               else
C                 WRITE(6,1001) QV2,B(3, KBNEW)
c Search alternately fwd and bkwd from KBNEW in the boundary list B()
c for the point QV2.  When found set the associated triangle to TNEW.
                  KFWD = KBNEW
                  KBKWD= B(2, KFWD )
   90             continue
                     if (KFWD .ne. 0) then
                        if (B(3, KFWD) .eq. QV2) then
                           B(4, KFWD) = TNEW
                           go to 100
                        end if
                        KFWD = B(1, KFWD)
                     end if
C
                     if (KBKWD .ne. 0) then
                        if (B(3, KBKWD) .eq. QV2) then
                           B(4, KBKWD) = TNEW
                           go to 100
                        end if
                        KBKWD = B(2, KBKWD)
                     end if
                  go to 90
               end if
            end if
C
  100       TNEW=T1
            if ( T22 .ne. 0) then
               call DTGGET( T22,TRI2, TRIANG)
               DO 110 I = 1, 3
                  if (TRI2(I) .eq. T2) then
                     TRI2(I) = TNEW
                     go to 120
                  end if
  110          continue
  120          call DTGPUT( T22,TRI2, TRIANG, MT)
            else
C              WRITE(6,1002) QV4
c Search alternately fwd and bkwd from KBNEW in the boundary list B()
c for the point QV2.  When found set the associated triangle to TNEW.
               KFWD = KBNEW
               KBKWD= B(2, KFWD )
  140          continue
                  if (KFWD .ne. 0) then
                     if (B(3, KFWD) .eq. QV4) then
                        B(4, KFWD) = TNEW
                        go to 150
                     end if
                     KFWD = B(1, KFWD)
                  end if
C
                  if (KBKWD .ne. 0) then
                     if (B(3, KBKWD) .eq. QV4) then
                        B(4, KBKWD) = TNEW
                        go to 150
                     end if
                     KBKWD = B(2, KBKWD)
                  end if
               go to 140
            end if
  150       NABOR1 = 3
            MORE = MORE+1
            COUNT = COUNT+1
            OK = COUNT .le. 100
         else
            MORE = MORE-1
            if (MORE .gt. 0) then
               TOLD = T1
               I = SUB1(NABOR1)
               T1=TRI1(I)
               call DTGGET(T1,TRI1,TRIANG)
               do 160 K = 1, 3
                  if (TRI1(K) .eq. TOLD) then
                     NABOR1 = SUB1(K)
                     go to 20
                  end if
  160          continue
            end if
         end if
         go to 20
      end if
      return
C
C1001 FORMAT(33H0ADJUST..  USING FIX-B WITH QV2 =,I5,5X,
C    * 12HB(3, KBNEW) =,I5)
C1002 FORMAT(33H0ADJUST..  USING FIX-B WITH QV4 =,I5)
      end


      program GF_num_inb ! Numerical calculation of the half-space
                         ! electromagnetic Green's tensor
                         ! by discretization of the Sommerfeld integrals
                         !
                         ! This program uses intrinsic Bessel functions
c-----------------------------------------------------------------------
c               Authors:
c                  George Y. Panasyuk, Vadim A. Markel, John C. Schotland
c                  University of Pennsylvania
c               E-mail address for questions and comments:
c                  vmarkel@mail.med.upenn.edu
c               For updates and additional info check
c                  URL: http://whale.seas.upenn.edu/CODES/
c--------------------------------------------------------------------------
      implicit none

      integer*4 key, nl, kl, idummy
      logical*4 logscale
      character*4 hdummy, output_prec, lambda_scale

      integer*8 N1, N2, N3, k

      real*8 ru, rz, two, three, four, half, pi, twopi, power
      real*8 lambda, lambda_max, lambda_min, dlambda, rlambda, lambda_p
      real*8 w, J0, J1, J0Hat, J1Hat
      real*8 y, y2, y3, y4, dy1, dy2, dy3, y_max
      real*8 t, gd, delta
      real*8 Rhat, Zhat_m, Zhat_p
      real*8 z1, z2, z_p, z_m, rho
      real*8 Rti, k1
      real*8 rpe, div, r_p, r_m
      real*8 xh, xh_2, zh_p, zh_p_2, zh_m, zh_m_2
      real*8 RJ01p, RJ0p, RJ1p
      real*8 DBESJ0, DBESJ1
      real*8 eps_2_r, eps_2_i, eps_1, eps0

      complex*16 cu, cz, eps, eps_2, eps1, kzeps
      complex*16 R, Rpr
      complex*16 c2, c3, cpe
      complex*16 J01p, J0p, J1p
      complex*16 s1xx,s1yy,s1xz,s1zz,s2xx,s2yy,s2xz,s2zz
      complex*16 sum1xz,sum2xz
      complex*16 sum1xx_a,sum1xx_b,sum1xx_c
      complex*16 sum1yy_a,sum1yy_b,sum1yy_c
      complex*16 sum1zz_a,sum1zz_b,sum1zz_c
      complex*16 sum2xx_a,sum2xx_b,sum2xx_c
      complex*16 sum2yy_a,sum2yy_b,sum2yy_c
      complex*16 sum2zz_a,sum2zz_b,sum2zz_c
      complex*16 Gxx1a,Gxx1b,Gxx2a1,Gxx2a2,Gxx2ah,Gxx2bh,Gxx2b1,Gxx2b2
      complex*16 Gyy1a,Gyy1b,Gyy2a1,Gyy2a2,Gyy2ah,Gyy2bh,Gyy2b1,Gyy2b2
      complex*16 Gzz1,Gzz2b1,Gzz2b2,Gzz2
      complex*16 Gxz1,Gxz2a1,Gxz2a2,Gxz2
      complex*16 GTxx,GTyy,GTzz,GTxz,GTzx
      complex*16 GFxx,GFyy,GFzz,GFxz,GFzx
      complex*16 GRxx,GRyy,GRzz,GRxz,GRzx

c
c------ Mathematical constants ------------------------------------
c
      rz    = 0.0d0
      ru    = 1.0d0
      cz    = (0.0d0,0.0d0)
      cu    = (0.0d0,1.0d0)
      two   = 2.0d0
      three = 3.0d0
      four  = 4.0d0
      half  = 0.5d0
      pi    = two*dasin(1.0d0)
      twopi = two*pi
      delta = 1.d-100
c
c---------- Reading input parameters -----------------------------------
c
      open(unit=70, file='GF.par', status='old', err=101)
      read(70,*) hdummy
      read(70,*) hdummy

      read(70,*) key
      if(key .eq. 0) then
         write(*,*) 'Assuming a metallic substrate'
         write(*,*) 'Drude formula will be used for eps_2'
      else if (key .eq. 1) then
         write(*,*) 'Assuming that the substrate has a'
         write(*,*) '   ... wavelength-independent permittivity'
         write(*,*) '   ... eps_2 = eps_2_r + i*eps_2_i'
         write(*,*) '   ... where eps_2_r, eps_2_i are given in GF.par'
         write(*,*) 'If you dont like this, use KEY=2'
         write(*,*) '   ... and program your own formula for eps_2'
      else if (key .eq. 2) then
         write(*,*) 'KEY=2 is used for user-defined permittivity'
         write(*,*) 'This option requires additional programming'
         write(*,*) 'But this has not been done so far'
         write(*,*) 'Go to the line "if(key .eq. 2)" below'
         write(*,*) ' ...and add your code directly after that line'
         write(*,*) 'Then comment this message out'
         write(*,*) 'For now, I am exiting. Goodby'
         stop
      else
         write(*,*) 'Error. Incorrect parameter: KEY=', key
         write(*,*) 'KEY is allowed to take only the values 0,1,2'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) idummy

      read(70,2) output_prec
      if(output_prec .eq. 'S') goto 3
      if(output_prec .eq. 's') goto 3
      if(output_prec .eq. 'D') goto 3
      if(output_prec .eq. 'd') goto 3
         write(*,*) 'Incorrect parameter OUTPUT_PREC'
         write(*,*) 'Only chars S, s, D, d are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 3    continue

      read(70,4) lambda_scale
      if(lambda_scale .eq. 'LOG') goto 5
      if(lambda_scale .eq. 'log') goto 5
      if(lambda_scale .eq. 'LIN') goto 5
      if(lambda_scale .eq. 'lin') goto 5
         write(*,*) 'Incorrect parameter LAMBDA_SCALE'
         write(*,*) 'Only "LOG", "log", "LIN", "lin" are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 5    continue

      read(70,*) lambda_min, lambda_max, nl
      write(*,*) 'lambda_min,lambda_max:', sngl(lambda_min),
     $                                     sngl(lambda_max), '  [nm]'
      write(*,*) 'nl:', nl
      if(lambda_min.lt.rz) then
         write(*,*) 'Error. Incorrect parameters: lambda_min<0'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if(lambda_min.gt.lambda_max) then
         write(*,*) 'Error. Incorrect parameters: lambda_min>lambda_max'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if((lambda_min.eq.lambda_max) .and. (nl.ne.1) ) then
         write(*,*) 'Warning. lambda_min=lambda_max but nl=/=1'
         write(*,*) 'Setting nl=1 and continuing'
         nl=1
      else if((lambda_min .lt. lambda_max) .and. (nl.lt.2)) then
         write(*,*) 'Warning. lambda_min<lambda_max but nl<2'
         write(*,*) 'Setting nl=2 and continuing'
         nl=2
      end if

      read(70,*) z1, z2, rho
      if(z1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z1<=0; z1=', z1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(z2.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z2<=0; z2=', z2
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(rho.le.rz) then
         write(*,*) 'Error. Incorrect parameter: rho<=0; rho=', rho
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) eps_2_r, eps_2_i
      if(eps_2_i.lt.rz) then
         write(*,*) 'Error. Incorrect parameter: eps_2_i<0; eps_2_i=',
     $                                                     eps_2_i
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) lambda_p
      if(lambda_p.le.rz) then
         write(*,*) 'Error. Incorrect parameter: lambda_p<=0;
     $                                           lambda_p=', lambda_p
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) gd
      if(gd.lt.rz) then
         write(*,*) 'Error. Incorrect parameter: gd<0; gd=', gd
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if(gd. lt. 0.0002) then
         write(*,*) 'Warning. Unrealistically small value: gd=', gd
         write(*,*) 'This can cause slow numerical convergence'
         write(*,*) 'Check convergence by increasing N1, N2, N3'
         write(*,*) '   ... by the factor of 10'
         write(*,*) 'Or better yet, use GD>=0.002 (the value for Ag)'
      end if

      read(70,*) eps0

      read(70,*) eps_1
      if(eps_1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: eps_1<=0; eps_1=',
     $                                                     eps_1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) N1
      read(70,*) N2
      read(70,*) N3
      if(N1.lt.10) then
         write(*,*) 'Error. Incorrect parameter: N1<10; N1=', N1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(N2.lt.10) then
         write(*,*) 'Error. Incorrect parameter: N2<10; N2=', N2
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(N3.lt.10) then
         write(*,*) 'Error. Incorrect parameter: N2<10; N2=', N2
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if((N1 .ne. N2) .or. (N1 .ne. N3)) then
         write(*,*) 'You are using different values for N1,N2,N3'
         write(*,*) 'Are you sure you know what you are doing?'
      end if

      read(70,*) y_max, div
      if(y_max.le.rz) then
         write(*,*) 'Error. Incorrect parameter: y_max<=0; y_max=',
     $                                                     y_max
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(div.le.rz) then
         write(*,*) 'Error. Incorrect parameter: div<=0; div=', div
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      close(unit=70)
c
c------- End reading parameters -----------------------------
c

c
c------- Input-dependent constants --------------------------
c
      if(nl .gt. 1) then
         dlambda = (lambda_max - lambda_min)/dfloat(nl-1)
      else
         dlambda = rz
      end if

      z_p = z2 + z1
      z_m = z2 - z1
      r_p = dsqrt(rho*rho + z_p*z_p)
      r_m = dsqrt(rho*rho + z_m*z_m)
      zh_p   = z_p/r_p
      zh_p_2 = zh_p*zh_p
      zh_m   = z_m/r_m   ! used only for G^F
      zh_m_2 = zh_m*zh_m
      xh     = rho/r_m      ! used only for G^F
      xh_2   = xh*xh

      N1  = 2*(N1/2)
      N2  = 2*(N2/2)
      N3  = 2*(N3/2)
      dy1 = ru/dfloat(N1)
      dy2 = div/dfloat(N2)
      dy3 = (y_max-div) / dfloat(N3)

      logscale = .false.
      if(lambda_scale .eq. 'LOG') logscale=.true.
      if(lambda_scale .eq. 'log') logscale=.true.
      if(logscale) then
         if(lambda_min .eq. rz) then
            write(*,*) 'If using logscale, lambda_min=0 is not allowed'
            write(*,*) 'Correct GF.par and try again; exiting'
            stop
         end if
         rlambda = lambda_max/lambda_min
      end if
c
c-------- End input-dependent constants block ------------------------
c
      open(71, file='GRxx_num', status='unknown', err=102)
      open(72, file='GRyy_num', status='unknown', err=102)
      open(73, file='GRzz_num', status='unknown', err=102)
      open(74, file='GRxz_num', status='unknown', err=102)
      open(75, file='GRzx_num', status='unknown', err=102)

      open(76, file='GTxx_num', status='unknown', err=102)
      open(77, file='GTyy_num', status='unknown', err=102)
      open(78, file='GTzz_num', status='unknown', err=102)
      open(79, file='GTxz_num', status='unknown', err=102)
      open(80, file='GTzx_num', status='unknown', err=102)
c
c------- Start loop over wavelengths ---------------------------------
c
      do 1, kl=1,nl
      if(logscale) then
         power = dfloat(kl-1)/dfloat(nl-1)
         lambda = lambda_min * rlambda**power
      else
         lambda = lambda_min + dlambda*dfloat(kl-1)
      end if
      write(*,*) kl, ':   lambda=', sngl(lambda), '[nm]'

      k1 = twopi*dsqrt(eps_1)/lambda

      if(key .eq. 0) then
         t = lambda_p/lambda
         eps_2 = eps0 - ru/t/(t + cu*gd)
      else if(key .eq. 1) then
         eps_2 = eps_2_r + cu*eps_2_i
      else if(key .eq. 2) then
         ! Enter your own formula for eps_2 here
         continue
         ! Do not edit past this line
      else
         write(*,*) 'Unexpected error 1; exiting'
         write(*,*) 'Please report this error to code developers'
         stop
      end if

      eps_2 = dreal(eps_2) + cu*max(delta,dimag(eps_2))
      eps  = eps_2/eps_1
      eps1 = eps - ru

      Zhat_p = k1*z_p       ! Used for G^R
      Zhat_m = k1*z_m       ! Used for G^F
      Rhat   = k1*rho
      Rti    = dsqrt(Rhat*Rhat + Zhat_m*Zhat_m)   ! Argument for G^F

      J0Hat = DBESJ0(Rhat)
      J1Hat = DBESJ1(Rhat)/Rhat
c
c-------- Integrals over the finite interval (0,1) ---------
c                 dy = dy1 = 1/N1
c
      s2xx = -J1Hat
      s2yy =  rz
      s2zz =  J0Hat
      s2xz =  rz

      kzeps = cdsqrt(eps1 + ru)
      R   = (ru-kzeps) /(ru+kzeps)
      Rpr = (kzeps-eps)/(kzeps+eps)
      cpe = half*cdexp(cu*Zhat_p)
      s1xx = s2xx + cpe*R
      s1yy = s2yy + cpe*Rpr
      s1zz = s2zz
      s1xz = s2xz

      sum1xx_a = cz
      sum1yy_a = cz
      sum1zz_a = cz
      sum1xx_b = cz
      sum1yy_b = cz
      sum1xz   = cz
      do 11,k=1,N1-1,2
         y     = k*dy1
         y2    = y*y
         y3    = ru-y2
         y4    = y*y3
         kzeps = cdsqrt(eps1 + y2)
         R     = (y-kzeps)/(y+kzeps)
         Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
         cpe   = cdexp(cu*y*Zhat_p)
         w     = Rhat*dsqrt(y3)
            J0 = DBESJ0(w)
            J1 = DBESJ1(w)/w
         J01p  = (J0-J1)*cpe
         J1p   = J1*cpe
         J0p   = J0*cpe
         sum1xx_a = sum1xx_a + J1p  * R
         sum1yy_a = sum1yy_a + J1p  * Rpr * y2
         sum1zz_a = sum1zz_a + J0p  * Rpr * y3
         sum1xx_b = sum1xx_b + J01p * Rpr * y2
         sum1yy_b = sum1yy_b + J01p * R
         sum1xz   = sum1xz   + J1p  * Rpr * y4
 11   continue

      sum2xx_a = cz
      sum2yy_a = cz
      sum2zz_a = cz
      sum2xx_b = cz
      sum2yy_b = cz
      sum2xz   = cz
      do 12, k=2,N1-2,2
         y     = k*dy1
         y2    = y*y
         y3    = ru-y2
         y4    = y*y3
         kzeps = cdsqrt(eps1 + y2)
         R     = (y-kzeps)/(y+kzeps)
         Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
         cpe   = cdexp(cu*y*Zhat_p)
         w     = Rhat*dsqrt(y3)
            J0 = DBESJ0(w)
            J1 = DBESJ1(w)/w
         J01p  = (J0-J1)*cpe
         J1p   = J1*cpe
         J0p   = J0*cpe
         sum2xx_a = sum2xx_a + J1p  * R
         sum2yy_a = sum2yy_a + J1p  * Rpr * y2
         sum2zz_a = sum2zz_a + J0p  * Rpr * y3
         sum2xx_b = sum2xx_b + J01p * Rpr * y2
         sum2yy_b = sum2yy_b + J01p * R
         sum2xz   = sum2xz   + J1p  * Rpr * y4
 12   continue

      Gxx1a = dy1*(two*sum2xx_a + four*sum1xx_a + s1xx)/three
      Gyy1a = dy1*(two*sum2yy_a + four*sum1yy_a + s1yy)/three
      Gzz1  = dy1*(two*sum2zz_a + four*sum1zz_a + s1zz)/three
      Gxz1  = dy1*(two*sum2xz   + four*sum1xz   + s1xz)/three

      s2xx = rz
      s2yy = J1Hat-J0Hat

      kzeps = cdsqrt(eps1 + ru)
      Rpr   = (kzeps-eps)/(kzeps+eps)
      R     = (ru-kzeps)/(ru+kzeps)
      cpe   = half*cdexp(cu*Zhat_p)
      s1xx  = s2xx + cpe*Rpr
      s1yy  = s2yy + cpe*R

      Gxx1b = dy1*(two*sum2xx_b + four*sum1xx_b + s1xx)/three
      Gyy1b = dy1*(two*sum2yy_b + four*sum1yy_b + s1yy)/three
c
c-------- Integrals over the infinite interval (0,Inf) ---------
c-------- The integlas is broken in two parts ------------------
c-------- a) First, compute over the interval (0,div)
c                 dy = dy2 = div/N2
c
      s2xx = -J1Hat
      s2yy =  rz
      s2xz =  rz

      y     = div
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      R     = (y-kzeps)/(y+kzeps)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      w     = Rhat*dsqrt(ru+y2)
         J1 = DBESJ1(w)/w
      s1xx  = s2xx + rpe*J1*R
      s1yy  = s2yy + y2*rpe*J1*Rpr
      s1xz  = s2xz + y*(y2+ru)*rpe*J1*Rpr

      sum1xx_a = cz
      sum1yy_a = cz
      sum1xx_b = cz
      sum1yy_b = cz
      sum1zz_b = cz
      sum1xz   = cz
      do 21, k = 1, N2-1, 2
         y      = k*dy2
         y2     = y*y
         y3     = ru+y2
         y4     = y*y3
         rpe    = dexp(-y*Zhat_p)
         kzeps  = cdsqrt(y2-eps1)
         R      = (y-kzeps)/(y+kzeps)
         Rpr    = (kzeps-eps*y)/(kzeps+eps*y)
         w      = Rhat*dsqrt(y3)
             J0 = DBESJ0(w)
             J1 = DBESJ1(w)/w
         RJ01p  = (J0-J1)*rpe
         RJ1p   = J1*rpe
         RJ0p   = J0*rpe
         sum1xx_a = sum1xx_a + RJ1p  * R
         sum1yy_a = sum1yy_a + RJ1p  * Rpr * y2
         sum1xx_b = sum1xx_b + RJ01p * Rpr * y2
         sum1yy_b = sum1yy_b + RJ01p * R
         sum1zz_b = sum1zz_b + RJ0p  * Rpr * y3
         sum1xz   = sum1xz   + RJ1p  * Rpr * y4
 21   continue

      sum2xx_a = cz
      sum2yy_a = cz
      sum2xx_b = cz
      sum2yy_b = cz
      sum2zz_b = cz
      sum2xz   = cz
      do 22, k = 2, N2-2, 2
         y      = k*dy2
         y2     = y*y
         y3     = ru+y2
         y4     = y*y3
         rpe    = dexp(-y*Zhat_p)
         kzeps  = cdsqrt(y2-eps1)
         R      = (y-kzeps)/(y+kzeps)
         Rpr    = (kzeps-eps*y)/(kzeps+eps*y)
         w      = Rhat*dsqrt(y3)
             J0 = DBESJ0(w)
             J1 = DBESJ1(w)/w
         RJ01p  = (J0-J1)*rpe
         RJ1p   = J1*rpe
         RJ0p   = J0*rpe
         sum2xx_a = sum2xx_a + RJ1p  * R
         sum2yy_a = sum2yy_a + RJ1p  * Rpr * y2
         sum2xx_b = sum2xx_b + RJ01p * Rpr * y2
         sum2yy_b = sum2yy_b + RJ01p * R
         sum2zz_b = sum2zz_b + RJ0p  * Rpr * y3
         sum2xz   = sum2xz   + RJ1p  * Rpr * y4
 22   continue

      Gxx2a1 = dy2*(two*sum2xx_a + four*sum1xx_a + s1xx)/three
      Gyy2a1 = dy2*(two*sum2yy_a + four*sum1yy_a + s1yy)/three
      Gxz2a1 = dy2*(two*sum2xz   + four*sum1xz   + s1xz)/three
c
c-------- Integrals over the infinite interval (0,Inf) ---------
c-------- The integlas is broken in two parts ------------------
c-------- b) Second part, compute over the interval (div,y_max)
c                 dy = dy3 = (y_max-div)/N3
c
      y     = div
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      R     = (y-kzeps)/(y+kzeps)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      w     = Rhat*dsqrt(ru+y2)
         J1 = DBESJ1(w)/w
      s2xx  = rpe*J1*R
      s2yy  = y2*rpe*J1*Rpr
      s2xz  = y*(y2+ru)*rpe*J1*Rpr

      y     = y_max
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      R     = (y-kzeps)/(y+kzeps)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      w     = Rhat*dsqrt(ru+y2)
         J1 = DBESJ1(w)/w
      s1xx  = s2xx + rpe*J1*R
      s1yy  = s2yy + y2*rpe*J1*Rpr
      s1xz  = s2xz + y*(y2+ru)*rpe*J1*Rpr

      sum1xx_a = cz
      sum1yy_a = cz
      sum1xz   = cz
      sum1xx_c = cz
      sum1yy_c = cz
      sum1zz_c = cz
      do 31, k = 1, N3-1, 2
         y      = div + k*dy3
         y2     = y*y
         y3     = ru+y2
         y4     = y*y3
         rpe    = dexp(-y*Zhat_p)
         kzeps  = cdsqrt(y2-eps1)
         R      = (y-kzeps)/(y+kzeps)
         Rpr    = (kzeps-eps*y)/(kzeps+eps*y)
         w      = Rhat*dsqrt(y3)
             J0 = DBESJ0(w)
             J1 = DBESJ1(w)/w
         RJ01p  = (J0-J1)*rpe
         RJ1p   = J1*rpe
         RJ0p   = J0*rpe
         sum1xx_a = sum1xx_a + RJ1p  * R
         sum1yy_a = sum1yy_a + RJ1p  * Rpr * y2
         sum1xz   = sum1xz   + RJ1p  * Rpr * y4
         sum1xx_c = sum1xx_c + RJ01p * Rpr * y2
         sum1yy_c = sum1yy_c + RJ01p * R
         sum1zz_c = sum1zz_c + RJ0p  * Rpr * y3
 31   continue

      sum2xx_a = cz
      sum2yy_a = cz
      sum2xz   = cz
      sum2xx_c = cz
      sum2yy_c = cz
      sum2zz_c = cz
      do 32, k = 2, N3-2, 2
         y      = div + k*dy3
         y2     = y*y
         y3     = ru+y2
         y4     = y*y3
         rpe    = dexp(-y*Zhat_p)
         kzeps  = cdsqrt(y2-eps1)
         R      = (y-kzeps)/(y+kzeps)
         Rpr    = (kzeps-eps*y)/(kzeps+eps*y)
         w      = Rhat*dsqrt(y3)
             J0 = DBESJ0(w)
             J1 = DBESJ1(w)/w
         RJ01p  = (J0-J1)*rpe
         RJ1p   = J1*rpe
         RJ0p   = J0*rpe
         sum2xx_a = sum2xx_a + RJ1p  * R
         sum2yy_a = sum2yy_a + RJ1p  * Rpr * y2
         sum2xz   = sum2xz   + RJ1p  * Rpr * y4
         sum2xx_c = sum2xx_c + RJ01p * Rpr * y2
         sum2yy_c = sum2yy_c + RJ01p * R
         sum2zz_c = sum2zz_c + RJ0p  * Rpr * y3
 32   continue

      Gxx2a2 = dy3*(two*sum2xx_a + four*sum1xx_a + s1xx)/three
      Gyy2a2 = dy3*(two*sum2yy_a + four*sum1yy_a + s1yy)/three
      Gxz2a2 = dy3*(two*sum2xz   + four*sum1xz   + s1xz)/three
      Gxx2ah = Gxx2a1 + Gxx2a2
      Gyy2ah = Gyy2a1 + Gyy2a2
      Gxz2   = Gxz2a1 + Gxz2a2

      s2xx = rz
      s2yy = J1Hat - J0Hat
      s2zz = J0Hat

      y     = div
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      R     = (y-kzeps)/(y+kzeps)
      w     = Rhat*dsqrt(ru+y2)
         J0 = DBESJ0(w)
         J1 = DBESJ1(w)/w
      s1xx  = s2xx + y2*rpe*Rpr*(J0-J1)
      s1yy  = s2yy + rpe*R*(J0-J1)
      s1zz  = s2zz + (y2+ru)*rpe*Rpr*J0

      Gxx2b1 = dy2*(two*sum2xx_b + four*sum1xx_b + s1xx)/three
      Gyy2b1 = dy2*(two*sum2yy_b + four*sum1yy_b + s1yy)/three
      Gzz2b1 = dy2*(two*sum2zz_b + four*sum1zz_b + s1zz)/three

      y     = div
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      R     = (y-kzeps)/(y+kzeps)
      w     = Rhat*dsqrt(ru+y2)
         J0 = DBESJ0(w)
         J1 = DBESJ1(w)/w
      s2xx  = y2*rpe*Rpr*(J0-J1)
      s2yy  = rpe*R*(J0-J1)
      s2zz  = (y2+ru)*rpe*Rpr*J0

      y     = y_max
      y2    = y*y
      rpe   = dexp(-y*Zhat_p)
      kzeps = cdsqrt(y2-eps1)
      Rpr   = (kzeps-eps*y)/(kzeps+eps*y)
      R     = (y-kzeps)/(y+kzeps)
      w     = Rhat*dsqrt(ru+y2)
         J0 = DBESJ0(w)
         J1 = DBESJ1(w)/w
      s1xx  = s2xx + y2*rpe*Rpr*(J0-J1)
      s1yy  = s2yy + rpe*R*(J0-J1)
      s1zz  = s2zz + (y2+ru)*rpe*Rpr*J0

      Gxx2b2 = dy3*(two*sum2xx_c + four*sum1xx_c + s1xx)/three
      Gyy2b2 = dy3*(two*sum2yy_c + four*sum1yy_c + s1yy)/three
      Gzz2b2 = dy3*(two*sum2zz_c + four*sum1zz_c + s1zz)/three

      Gxx2bh = Gxx2b1 + Gxx2b2
      Gyy2bh = Gyy2b1 + Gyy2b2
      Gzz2   = Gzz2b1 + Gzz2b2

c     Dimensionless G^R/k1**3
      GRxx = cu*(Gxx1a + Gxx1b) + Gxx2ah - Gxx2bh
      GRyy = cu*(Gyy1a + Gyy1b) + Gyy2bh - Gyy2ah
      GRzz = -cu*Gzz1 - Gzz2
      GRxz = -Rhat*(Gxz1 + Gxz2)
      GRzx = -GRxz

c     Dimensionless G^F/k1**3
      c2 = cdexp(cu*Rti)/Rti
      c3 = (cu - ru/Rti)/Rti
      GFxx = c2*(ru - xh_2 + c3*(ru - three*xh_2))
      GFyy = c2*(ru + c3)
      GFzz = c2*(ru - zh_m_2 + c3*(ru-three*zh_m_2))
      GFxz = c2*xh*zh_m*(three*c3 + ru)
      GFzx = GFxz

c     Dimensionless G^T/k1**3, where G^T=G^F+G^R
      GTxx =  GRxx + GFxx
      GTyy =  GRyy + GFyy
      GTzz =  GRzz + GFzz
      GTxz =  GRxz + GFxz
      GTzx =  GRzx + GFzx

      if((output_prec.eq.'S') .or. (output_prec.eq.'s')) then

         write(71,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxx)), sngl(dimag(GRxx))
         write(72,6,err=102) sngl(lambda),
     $      sngl(dreal(GRyy)), sngl(dimag(GRyy))
         write(73,6,err=102) sngl(lambda),
     $      sngl(dreal(GRzz)), sngl(dimag(GRzz))
         write(74,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxz)), sngl(dimag(GRxz))
         write(75,6,err=102) sngl(lambda),
     $      sngl(dreal(GRzx)), sngl(dimag(GRzx))

         write(76,6,err=102) sngl(lambda),
     $      sngl(dreal(GTxx)), sngl(dimag(GTxx))
         write(77,6,err=102) sngl(lambda),
     $      sngl(dreal(GTyy)), sngl(dimag(GTyy))
         write(78,6,err=102) sngl(lambda),
     $      sngl(dreal(GTzz)), sngl(dimag(GTzz))
         write(79,6,err=102) sngl(lambda),
     $      sngl(dreal(GTxz)), sngl(dimag(GTxz))
         write(80,6,err=102) sngl(lambda),
     $      sngl(dreal(GTzx)), sngl(dimag(GTzx))

      else if((output_prec.eq.'D') .or. (output_prec.eq.'d')) then

         write(71,8,err=102) sngl(lambda), dreal(GRxx), dimag(GRxx)
         write(72,8,err=102) sngl(lambda), dreal(GRyy), dimag(GRyy)
         write(73,8,err=102) sngl(lambda), dreal(GRzz), dimag(GRzz)
         write(74,8,err=102) sngl(lambda), dreal(GRxz), dimag(GRxz)
         write(75,8,err=102) sngl(lambda), dreal(GRzx), dimag(GRzx)

         write(76,8,err=102) sngl(lambda), dreal(GTxx), dimag(GTxx)
         write(77,8,err=102) sngl(lambda), dreal(GTyy), dimag(GTyy)
         write(78,8,err=102) sngl(lambda), dreal(GTzz), dimag(GTzz)
         write(79,8,err=102) sngl(lambda), dreal(GTxz), dimag(GTxz)
         write(80,8,err=102) sngl(lambda), dreal(GTzx), dimag(GTzx)

      else

          write(*,*) 'Unexpected error 2; exiting'
          write(*,*) 'Please report this error to code developers'
          stop

      end if

c$$$  These lines to be used for debugging only
c$$$       write(*,*) '-----------------------------------------'
c$$$       write(*,*) 'XX-I:', dimag(GRxx)
c$$$       write(*,*) 'XX-R:', dreal(GRxx)
c$$$       write(*,*) 'YY-I:', dimag(GRyy)
c$$$       write(*,*) 'YY-R:', dreal(GRyy)
c$$$       write(*,*) 'ZZ-I:', dimag(GRzz)
c$$$       write(*,*) 'ZZ-R:', dreal(GRzz)
c$$$       write(*,*) 'XZ-I:', dimag(GRxz)
c$$$       write(*,*) 'XZ-R:', dreal(GRxz)

 1    continue
      close(unit=71)
      close(unit=72)
      close(unit=73)
      close(unit=74)
      close(unit=75)
      close(unit=76)
      close(unit=77)
      close(unit=78)
      close(unit=79)
      close(unit=80)

      stop

 101  continue
      write(*,*) 'Error opening input file GF.par; exiting'
      stop

 102  continue
      write(*,*) 'Error opening an output file or writing data; exiting'
      stop

 2    format(a1)
 4    format(a3)
 6    format(3G16.7E3)
 8    format(3G23.14E3)

      end