C****
C**** FUNTABLE.OCN   Table functions of ocean parameters   10/09/91
C****
      MODULE OCFUNC
!@sum  OCFUNC contains the ocean function lookup tables
!@auth Gary Russell/Gavin Schmidt
!@ver  1.0
      IMPLICIT NONE
      SAVE
C**** All look up tables take specific pot. enthalpy (J/kg),
C**** salinity (ppt) and pressure (MPa = 10^6 Pa) as arguments
!@var VGSP specific volume (m^3/kg)
!@var TGSP potential temperature (C)
!@var HGSP specific enthalpy of seawater (J/kg)
!@var AGSP thermal expansion coefficient (kg/m**3/C)
!@var BGSP saline expansion coefficient (kg/m**3/PSU)
!@var CGS specific heat capacity of sea water (J/kg*C)
      REAL*8, DIMENSION(-2:40,0:40,0:39) :: VGSP,TGSP,HGSP,AGSP,BGSP
      REAL*8, DIMENSION(-2:40,0:40) :: CGS
      END MODULE OCFUNC

      REAL*8 FUNCTION VOLGSP (G,S,P)
C****
C**** VOLGSP returns a linearly interpolated specific volume from
C**** an input table that depends on potential specific enthalpy,
C**** salinity, and pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****          P (Pa) = pressure above normal atmospheric pressure,
C****                   from 0 to 78.E6
C****
C**** Output: VOLGSP (m**3/kg) = specific volume of sea water
C****
      USE OCFUNC, only : v=>vgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S,P
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      PP = P*5d-7     ! /2.D6
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
      KP = PP
      IF(KP.LT. 0)  KP =  0
      IF(KP.GE.39)  KP = 38
C****
      VOLGSP = (KP-PP+1)*((JS-SS+1)*((IG-GG+1)*V(IG  ,JS  ,KP  )
     *                             + (GG-IG  )*V(IG+1,JS  ,KP  ))
     *                  + (SS-JS  )*((IG-GG+1)*V(IG  ,JS+1,KP  )
     *                             + (GG-IG  )*V(IG+1,JS+1,KP  )))
     *       + (PP-KP  )*((JS-SS+1)*((IG-GG+1)*V(IG  ,JS  ,KP+1)
     *                             + (GG-IG  )*V(IG+1,JS  ,KP+1))
     *                  + (SS-JS  )*((IG-GG+1)*V(IG  ,JS+1,KP+1)
     *                             + (GG-IG  )*V(IG+1,JS+1,KP+1)))
      RETURN
      END

      REAL*8 FUNCTION VOLGS (G,S)
C****
C**** VOLGS returns a linearly interpolated specific volume from
C**** an input table that depends on potential specific enthalpy
C**** and salinity.  Pressure is assumed to be the normal surface
C**** ocean reference pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****
C**** Output: VOLGS (m**3/kg) = specific volume of sea water
C****
      USE OCFUNC, only : v=>vgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S
      REAL*8 GG,SS
      INTEGER IG,JS
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
C****
      VOLGS = (JS-SS+1)*((IG-GG+1)*V(IG  ,JS  ,0)
     *                 + (GG-IG  )*V(IG+1,JS  ,0))
     *      + (SS-JS  )*((IG-GG+1)*V(IG  ,JS+1,0)
     *                 + (GG-IG  )*V(IG+1,JS+1,0))
      RETURN
      END

      REAL*8 FUNCTION TEMGS (G,S)
C****
C**** TEMGS returns a linearly interpolated temperature from an
C**** input table that depends on potential specific enthalpy and
C**** salinity.  Pressure is assumed to be the normal surface
C**** ocean reference pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****
C**** Output: TEMGS (C) = temperature of sea water
C****
      USE OCFUNC, only : t=>tgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S
      REAL*8 GG,SS
      INTEGER IG,JS
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
C****
      TEMGS = (JS-SS+1)*((IG-GG+1)*T(IG  ,JS  ,0)
     *                 + (GG-IG  )*T(IG+1,JS  ,0))
     *      + (SS-JS  )*((IG-GG+1)*T(IG  ,JS+1,0)
     *                 + (GG-IG  )*T(IG+1,JS+1,0))
      RETURN
      END

      REAL*8 FUNCTION SHCGS (G,S)
C****
C**** SHCGS returns a linearly interpolated specific heat capacity
C**** from an input table that depends on potential specific enthalpy
C**** and salinity.  Pressure is assumed to be the normal surface
C**** ocean reference pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****
C**** Output: SHCGS (J/kg*C) = specific heat capacity of sea water
C****
      USE OCFUNC, only : c=>cgs
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
C****
      SHCGS = (JS-SS+1)*((IG-GG+1)*C(IG  ,JS  )
     *                 + (GG-IG  )*C(IG+1,JS  ))
     *      + (SS-JS  )*((IG-GG+1)*C(IG  ,JS+1)
     *                 + (GG-IG  )*C(IG+1,JS+1))
      RETURN
      END

      REAL*8 FUNCTION GFREZS (S)
C****
C**** GFREZS returns a linearly interpolated frezzing point of
C**** potential specific enthalpy that depends on salinity.  Pressure
C**** is assumed to be the normal surface ocean reference pressure.
C****
C**** Input: S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****
C**** Output: GFREZS (J/kg) = freezing point of potential specific
C****                         enthalpy
C****
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: S
      REAL*8 F(0:40)
      DATA F /                                                0.000,
     * -232.482d0,  -461.136d0,  -688.288d0,  -914.774d0, -1141.078d0,
     *-1367.530d0, -1594.374d0, -1821.798d0, -2049.957d0, -2278.978d0,
     *-2508.971d0, -2740.030d0, -2972.237d0, -3205.667d0, -3440.386d0,
     *-3676.454d0, -3913.926d0, -4152.851d0, -4393.287d0, -4635.259d0,
     *-4878.815d0, -5123.994d0, -5370.830d0, -5619.358d0, -5869.609d0,
     *-6121.615d0, -6375.402d0, -6631.001d0, -6888.436d0, -7147.733d0,
     *-7408.917d0, -7672.010d0, -7937.037d0, -8204.019d0, -8472.976d0,
     *-8743.931d0, -9016.917d0, -9291.927d0, -9568.992d0, -9848.131d0/
      REAL*8 SS
      INTEGER JS
C****
      SS = S*1000.
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
C****
      GFREZS = (JS-SS+1)*F(JS) + (SS-JS)*F(JS+1)
      RETURN
      END

      REAL*8 FUNCTION TFREZS (SIN)
C****
C**** TFREZS calculates the freezing temperature of sea water as a
C**** function of salinity.
C**** The reference for this function is:
C**** N.P. Fofonoff and R.C. Millard Jr., 1983.  Algorithms for
C**** Computation of Fundamental Properties of Seawater.  UNESCO
C**** Technical Papers in Marine Science, volume 44.
C****
C**** Input: SIN (1) = salinity (kg NaCl/kg sea water), from .004 to .04
C****
C**** Output: TFREZS (C) = freezing temperature of sea water
C****
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: SIN
      REAL*8 :: A01 = -.0575d0, A02 = -2.154996D-4, A03 =1.710523D-3
      REAL*8 S,S32
C****
      S   = SIN*1.D3
      S32 = S*DSQRT(S)
      TFREZS = (A01 + A02*S)*S + A03*S32
      RETURN
      END

      REAL*8 FUNCTION HETGSP (G,S,P)
C****
C**** HETGSP returns a linearly interpolated specific enthalpy from
C**** an input table that depends on potential specific enthalpy,
C**** salinity, and pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****          P (Pa) = pressure above normal atmospheric pressure,
C****                   from 0 to 78.E6
C****
C**** Output: HETGSP (J/kg) = specific enthalpy of sea water
C****
      USE OCFUNC, only : h=>hgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S,P
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      PP = P*5d-7     ! /2.D6
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
      KP = PP
      IF(KP.LT. 0)  KP =  0
      IF(KP.GE.39)  KP = 38
C****
      HETGSP = (KP-PP+1)*((JS-SS+1)*((IG-GG+1)*H(IG  ,JS  ,KP  )
     *                             + (GG-IG  )*H(IG+1,JS  ,KP  ))
     *                  + (SS-JS  )*((IG-GG+1)*H(IG  ,JS+1,KP  )
     *                             + (GG-IG  )*H(IG+1,JS+1,KP  )))
     *       + (PP-KP  )*((JS-SS+1)*((IG-GG+1)*H(IG  ,JS  ,KP+1)
     *                             + (GG-IG  )*H(IG+1,JS  ,KP+1))
     *                  + (SS-JS  )*((IG-GG+1)*H(IG  ,JS+1,KP+1)
     *                             + (GG-IG  )*H(IG+1,JS+1,KP+1)))
      RETURN
      END

      REAL*8 FUNCTION ALPHAGSP (G,S,P)
C****
C**** ALPHAGSP returns a linearly interpolated thermal expansion
C**** coefficient from an input table that depends on potential
C**** specific enthalpy, salinity, and pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****          P (Pa) = pressure above normal atmospheric pressure,
C****                   from 0 to 78.E6
C****
C**** Output: ALPHAGSP (kg/m**3/C) = thermal expansion coefficient
C****
      USE OCFUNC, only : a=>agsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S,P
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      PP = P*5d-7     ! /2.D6
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
      KP = PP
      IF(KP.LT. 0)  KP =  0
      IF(KP.GE.39)  KP = 38
C****
      ALPHAGSP=(KP-PP+1)*((JS-SS+1)*((IG-GG+1)*A(IG  ,JS  ,KP  )
     *                             + (GG-IG  )*A(IG+1,JS  ,KP  ))
     *                  + (SS-JS  )*((IG-GG+1)*A(IG  ,JS+1,KP  )
     *                             + (GG-IG  )*A(IG+1,JS+1,KP  )))
     *       + (PP-KP  )*((JS-SS+1)*((IG-GG+1)*A(IG  ,JS  ,KP+1)
     *                             + (GG-IG  )*A(IG+1,JS  ,KP+1))
     *                  + (SS-JS  )*((IG-GG+1)*A(IG  ,JS+1,KP+1)
     *                             + (GG-IG  )*A(IG+1,JS+1,KP+1)))
      RETURN
      END

      REAL*8 FUNCTION BETAGSP (G,S,P)
C****
C**** BETAGSP returns a linearly interpolated saline expansion
C**** coefficient from an input table that depends on potential
C**** specific enthalpy, salinity, and pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****          P (Pa) = pressure above normal atmospheric pressure,
C****                   from 0 to 78.E6
C****
C**** Output: BETAGSP (kg/m**3/PSU) = saline expansion coefficient
C****
      USE OCFUNC, only : b=>bgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S,P
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      PP = P*5d-7     ! /2.D6
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
      KP = PP
      IF(KP.LT. 0)  KP =  0
      IF(KP.GE.39)  KP = 38
C****
      BETAGSP =(KP-PP+1)*((JS-SS+1)*((IG-GG+1)*B(IG  ,JS  ,KP  )
     *                             + (GG-IG  )*B(IG+1,JS  ,KP  ))
     *                  + (SS-JS  )*((IG-GG+1)*B(IG  ,JS+1,KP  )
     *                             + (GG-IG  )*B(IG+1,JS+1,KP  )))
     *       + (PP-KP  )*((JS-SS+1)*((IG-GG+1)*B(IG  ,JS  ,KP+1)
     *                             + (GG-IG  )*B(IG+1,JS  ,KP+1))
     *                  + (SS-JS  )*((IG-GG+1)*B(IG  ,JS+1,KP+1)
     *                             + (GG-IG  )*B(IG+1,JS+1,KP+1)))
      RETURN
      END

      REAL*8 FUNCTION TEMGSP (G,S,P)
C****
C**** TEMGSP returns a linearly interpolated in situ temperature
C**** from an input table that depends on potential
C**** specific enthalpy, salinity, and pressure.
C****
C**** Input: G (J/kg) = potential specific enthalpy,
C****                   from -8000 to 160000
C****           S (1) = salinity (kg NaCl/kg sea water), from 0 to .04
C****          P (Pa) = pressure above normal atmospheric pressure,
C****                   from 0 to 78.E6
C****
C**** Output: TEMGSP (C) = in situ temperature
C****
      USE OCFUNC, only : t=>tgsp
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: G,S,P
      REAL*8 GG,SS,PP
      INTEGER IG,JS,KP
C****
      GG = G*2.5d-4   ! /4000.
      SS = S*1000.
      PP = P*5d-7     ! /2.D6
      IG = INT(GG+2.) - 2
      IF(IG.LT.-2)  IG = -2
      IF(IG.GE.40)  IG = 39
      JS = SS
C     IF(JS.LT. 0)  JS =  0
      IF(JS.GE.40)  JS = 39
      KP = PP
      IF(KP.LT. 0)  KP =  0
      IF(KP.GE.39)  KP = 38
C****
      TEMGSP = (KP-PP+1)*((JS-SS+1)*((IG-GG+1)*T(IG  ,JS  ,KP  )
     *                             + (GG-IG  )*T(IG+1,JS  ,KP  ))
     *                  + (SS-JS  )*((IG-GG+1)*T(IG  ,JS+1,KP  )
     *                             + (GG-IG  )*T(IG+1,JS+1,KP  )))
     *       + (PP-KP  )*((JS-SS+1)*((IG-GG+1)*T(IG  ,JS  ,KP+1)
     *                             + (GG-IG  )*T(IG+1,JS  ,KP+1))
     *                  + (SS-JS  )*((IG-GG+1)*T(IG  ,JS+1,KP+1)
     *                             + (GG-IG  )*T(IG+1,JS+1,KP+1)))
      RETURN
      END


!*==zlatdf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLATDF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
!                          JPIV )
!
!       .. Scalar Arguments ..
!       INTEGER            IJOB, LDZ, N
!       DOUBLE PRECISION   RDSCAL, RDSUM
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * ), JPIV( * )
!       COMPLEX*16         RHS( * ), Z( LDZ, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLATDF computes the contribution to the reciprocal Dif-estimate
!> by solving for x in Z * x = b, where b is chosen such that the norm
!> of x is as large as possible. It is assumed that LU decomposition
!> of Z has been computed by ZGETC2. On entry RHS = f holds the
!> contribution from earlier solved sub-systems, and on return RHS = x.
!>
!> The factorization of Z returned by ZGETC2 has the form
!> Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
!> triangular with unit diagonal elements and U is upper triangular.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] IJOB
!> \verbatim
!>          IJOB is INTEGER
!>          IJOB = 2: First compute an approximative null-vector e
!>              of Z using ZGECON, e is normalized and solve for
!>              Zx = +-e - f with the sign giving the greater value of
!>              2-norm(x).  About 5 times as expensive as Default.
!>          IJOB .ne. 2: Local look ahead strategy where
!>              all entries of the r.h.s. b is chosen as either +1 or
!>              -1.  Default.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix Z.
!> \endverbatim
!>
!> \param[in] Z
!> \verbatim
!>          Z is COMPLEX*16 array, dimension (LDZ, N)
!>          On entry, the LU part of the factorization of the n-by-n
!>          matrix Z computed by ZGETC2:  Z = P * L * U * Q
!> \endverbatim
!>
!> \param[in] LDZ
!> \verbatim
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDA >= max(1, N).
!> \endverbatim
!>
!> \param[in,out] RHS
!> \verbatim
!>          RHS is COMPLEX*16 array, dimension (N).
!>          On entry, RHS contains contributions from other subsystems.
!>          On exit, RHS contains the solution of the subsystem with
!>          entries according to the value of IJOB (see above).
!> \endverbatim
!>
!> \param[in,out] RDSUM
!> \verbatim
!>          RDSUM is DOUBLE PRECISION
!>          On entry, the sum of squares of computed contributions to
!>          the Dif-estimate under computation by ZTGSYL, where the
!>          scaling factor RDSCAL (see below) has been factored out.
!>          On exit, the corresponding sum of squares updated with the
!>          contributions from the current sub-system.
!>          If TRANS = 'T' RDSUM is not touched.
!>          NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.
!> \endverbatim
!>
!> \param[in,out] RDSCAL
!> \verbatim
!>          RDSCAL is DOUBLE PRECISION
!>          On entry, scaling factor used to prevent overflow in RDSUM.
!>          On exit, RDSCAL is updated w.r.t. the current contributions
!>          in RDSUM.
!>          If TRANS = 'T', RDSCAL is not touched.
!>          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
!>          ZTGSYL.
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N).
!>          The pivot indices; for 1 <= i <= N, row i of the
!>          matrix has been interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[in] JPIV
!> \verbatim
!>          JPIV is INTEGER array, dimension (N).
!>          The pivot indices; for 1 <= j <= N, column j of the
!>          matrix has been interchanged with column JPIV(j).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!>  This routine is a further developed implementation of algorithm
!>  BSOLVE in [1] using complete pivoting in the LU factorization.
!
!> \par Contributors:
!  ==================
!>
!>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!>     Umea University, S-901 87 Umea, Sweden.
!
!> \par References:
!  ================
!>
!>   [1]   Bo Kagstrom and Lars Westin,
!>         Generalized Schur Methods with Condition Estimators for
!>         Solving the Generalized Sylvester Equation, IEEE Transactions
!>         on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
!>\n
!>   [2]   Peter Poromaa,
!>         On Efficient and Robust Estimators for the Separation
!>         between two Regular Matrix Pairs with Applications in
!>         Condition Estimation. Report UMINF-95.05, Department of
!>         Computing Science, Umea University, S-901 87 Umea, Sweden,
!>         1995.
!
!  =====================================================================
      SUBROUTINE ZLATDF(Ijob,N,Z,Ldz,Rhs,Rdsum,Rdscal,Ipiv,Jpiv)
      IMPLICIT NONE
!*--ZLATDF172
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      INTEGER Ijob , Ldz , N
      DOUBLE PRECISION Rdscal , Rdsum
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*) , Jpiv(*)
      COMPLEX*16 Rhs(*) , Z(Ldz,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER MAXDIM
      PARAMETER (MAXDIM=2)
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
      COMPLEX*16 CONE
      PARAMETER (CONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      INTEGER i , info , j , k
      DOUBLE PRECISION rtemp , scale , sminu , splus
      COMPLEX*16 bm , bp , pmone , temp
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION rwork(MAXDIM)
      COMPLEX*16 work(4*MAXDIM) , xm(MAXDIM) , xp(MAXDIM)
!     ..
!     .. External Subroutines ..
      EXTERNAL ZAXPY , ZCOPY , ZGECON , ZGESC2 , ZLASSQ , ZLASWP , ZSCAL
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DZASUM
      COMPLEX*16 ZDOTC
      EXTERNAL DZASUM , ZDOTC
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , SQRT
!     ..
!     .. Executable Statements ..
!
      IF ( Ijob/=2 ) THEN
!
!        Apply permutations IPIV to RHS
!
         CALL ZLASWP(1,Rhs,Ldz,1,N-1,Ipiv,1)
!
!        Solve for L-part choosing RHS either to +1 or -1.
!
         pmone = -CONE
         DO j = 1 , N - 1
            bp = Rhs(j) + CONE
            bm = Rhs(j) - CONE
            splus = ONE
!
!           Lockahead for L- part RHS(1:N-1) = +-1
!           SPLUS and SMIN computed more efficiently than in BSOLVE[1].
!
            splus = splus + DBLE(ZDOTC(N-j,Z(j+1,j),1,Z(j+1,j),1))
            sminu = DBLE(ZDOTC(N-j,Z(j+1,j),1,Rhs(j+1),1))
            splus = splus*DBLE(Rhs(j))
            IF ( splus>sminu ) THEN
               Rhs(j) = bp
            ELSEIF ( sminu>splus ) THEN
               Rhs(j) = bm
            ELSE
!
!              In this case the updating sums are equal and we can
!              choose RHS(J) +1 or -1. The first time this happens we
!              choose -1, thereafter +1. This is a simple way to get
!              good estimates of matrices like Byers well-known example
!              (see [1]). (Not done in BSOLVE.)
!
               Rhs(j) = Rhs(j) + pmone
               pmone = CONE
            ENDIF
!
!           Compute the remaining r.h.s.
!
            temp = -Rhs(j)
            CALL ZAXPY(N-j,temp,Z(j+1,j),1,Rhs(j+1),1)
         ENDDO
!
!        Solve for U- part, lockahead for RHS(N) = +-1. This is not done
!        In BSOLVE and will hopefully give us a better estimate because
!        any ill-conditioning of the original matrix is transferred to U
!        and not to L. U(N, N) is an approximation to sigma_min(LU).
!
         CALL ZCOPY(N-1,Rhs,1,work,1)
         work(N) = Rhs(N) + CONE
         Rhs(N) = Rhs(N) - CONE
         splus = ZERO
         sminu = ZERO
         DO i = N , 1 , -1
            temp = CONE/Z(i,i)
            work(i) = work(i)*temp
            Rhs(i) = Rhs(i)*temp
            DO k = i + 1 , N
               work(i) = work(i) - work(k)*(Z(i,k)*temp)
               Rhs(i) = Rhs(i) - Rhs(k)*(Z(i,k)*temp)
            ENDDO
            splus = splus + ABS(work(i))
            sminu = sminu + ABS(Rhs(i))
         ENDDO
         IF ( splus>sminu ) CALL ZCOPY(N,work,1,Rhs,1)
!
!        Apply the permutations JPIV to the computed solution (RHS)
!
         CALL ZLASWP(1,Rhs,Ldz,1,N-1,Jpiv,-1)
!
!        Compute the sum of squares
!
         CALL ZLASSQ(N,Rhs,1,Rdscal,Rdsum)
         RETURN
      ENDIF
!
!     ENTRY IJOB = 2
!
!     Compute approximate nullvector XM of Z
!
      CALL ZGECON('I',N,Z,Ldz,ONE,rtemp,work,rwork,info)
      CALL ZCOPY(N,work(N+1),1,xm,1)
!
!     Compute RHS
!
      CALL ZLASWP(1,xm,Ldz,1,N-1,Ipiv,-1)
      temp = CONE/SQRT(ZDOTC(N,xm,1,xm,1))
      CALL ZSCAL(N,temp,xm,1)
      CALL ZCOPY(N,xm,1,xp,1)
      CALL ZAXPY(N,CONE,Rhs,1,xp,1)
      CALL ZAXPY(N,-CONE,xm,1,Rhs,1)
      CALL ZGESC2(N,Z,Ldz,Rhs,Ipiv,Jpiv,scale)
      CALL ZGESC2(N,Z,Ldz,xp,Ipiv,Jpiv,scale)
      IF ( DZASUM(N,xp,1)>DZASUM(N,Rhs,1) ) CALL ZCOPY(N,xp,1,Rhs,1)
!
!     Compute the sum of squares
!
      CALL ZLASSQ(N,Rhs,1,Rdscal,Rdsum)
!
!     End of ZLATDF
!
      END SUBROUTINE ZLATDF


Devoted wiki gnomes are well familiar with the {{{Stats(Username)}}} macro that reports on a users past contribution to the wiki.  It lists (1) the number of pages edited, (2) pages created, and (3) the number of images contributed.  These stats are collectively displayed on the User Statistics page.  But how can one objectively compare the contributions of different users?  This is a question that has kept almost nobody awake at nightbut heres an answer anyway.

The difficulty of such a comparison lies in the fact that the three statistics reported are not of like units.  The first is in pages, the second in edits, and the third in images.  So the first step in comparison is to convert each to the same type of unit.  Of course every wiki gnomes preference is to convert them all to units of happiness or some other form of utility, but the metaphysics of such a conversion is beyond the abilities of this author.  Instead, well convert them to a more tangible form, words.

For Pages edited and Pages created, this is a straightforward procedure.  At the time of this page creation, the average words involved in the last 10 page edits and creationsFootNote(Redirects were ignored and only new new pages were counted.) was respectively 16.27 and 126.36.  So each page edit and created page will be worth this many words.  Converting images to words, however, involves a bit of handwaving so youll just have to trust me.  An image is worth a thousand words, so well set it at that.

So, here we have the standard conversion chart for comparison of user statistics:

Now, returning to the original statistics.  Take for example someone who has edited 4112 pages, created 256 pages, and contributed 326 images.  Their score in terms of words would be (4,112 edits  16.27 words) + (256 creations  126.37 words) + (326 images  1,000 words), which sums to 425,252.96 wordsa commendable total.  Any two users can thus be compared equally.

Using the stats available on the morning of May 9^th^, 2005 and a VERY subjective method of sorting users into classes the following table was created:

Primary role was assigned based on the relationship between a users three stats (edits, pages, photos).

Because number of reverts by a user is not currently given in the {{{Stats(Username)}}} wiki:wikispot:Help with Macros macro, the File(dwrevert.csh) script written by Users/CraigBrozinsky may be used to calculate the number of edits, reverts and ratio of reverts to edits of a user by analyzing their edit history pages.


module turbinflow_module

  implicit none

  logical, save :: turbinflow_initialized = .false.

  integer, save :: lenfname
  integer, save :: iturbfile(128)

  integer, save :: npboxcells(3)
  double precision, save :: pboxlo(3), dx(3), dxinv(3)

  integer, parameter :: nplane = 32
  double precision, allocatable, save :: sdata(:,:,:,:)
  double precision, save :: szlo=0.d0, szhi=0.d0

  integer, parameter :: isswirltype = 0  ! periodic
  double precision, save :: units_conversion = 100.d0  ! m --> cm & m/s --> cm/s

  private

  public :: turbinflow_initialized, init_turbinflow, get_turbvelocity

!$omp threadprivate(turbinflow_initialized,lenfname,iturbfile,npboxcells,pboxlo,dx,dxinv)
!$omp threadprivate(sdata,szlo,szhi,units_conversion)

contains

  subroutine init_turbinflow(turbfile, is_cgs)
    character (len=*), intent(in) :: turbfile
    logical, intent(in), optional :: is_cgs

    integer, parameter :: iunit = 20
    integer :: ierr, n, npts(3)
    double precision :: probsize(3), pboxsize(3)

    if (present(is_cgs)) then
       if (is_cgs) then
          units_conversion = 100.d0
       else
          units_conversion = 1.d0
       end if
    end if

    lenfname = len_trim(turbfile)
    do n=1,lenfname
       iturbfile(n) = ichar(turbfile(n:n))
    end do

    ! read header
    open(iunit, file=trim(turbfile)//'/HDR', form='formatted', action='read', &
         status='old', iostat=ierr)

    if (ierr .ne. 0) then
       call bl_abort('Problem opening file: ' // trim(turbfile) // '/HDR')
    end if

    read(iunit,*) npts
    read(iunit,*) probsize

    close(iunit)

    probsize = probsize * units_conversion

    dx = probsize / dble(npts-1)
    dxinv = 1.d0/dx

    pboxsize(1:2) = probsize(1:2) - 2.d0*dx(1:2)  ! because there is one ghost point on each side
    pboxsize(3) = probsize(3) ! no ghost point in z-direction

    npboxcells(1:2) = npts(1:2) - 3
    npboxcells(3)   = npts(3) - 1

    ! period box covers -0.5*pboxsize(1) <= x <= 0.5*pboxsize(1)
    !                   -0.5*pboxsize(2) <= y <= 0.5*pboxsize(2)
    !                                  0 <= z <= pboxsize(3)
    pboxlo(1:2) = -0.5d0*pboxsize(1:2)
    pboxlo(3) = 0.d0

    allocate(sdata(npts(1),npts(2),nplane,3))

    turbinflow_initialized = .true.

  end subroutine init_turbinflow

  subroutine get_turbvelocity(lo1,lo2,hi1,hi2,x,y,z,v)
    integer, intent(in) :: lo1,lo2,hi1,hi2
    double precision, intent(in) :: x(lo1:hi1), y(lo2:hi2)
    double precision, intent(in) :: z
    double precision, intent(out) :: v(lo1:hi1,lo2:hi2,3)

    integer :: i, j, k, n, i0, j0, k0, ii, jj
    double precision :: xx, yy, zz, zdata(0:2,0:2), ydata(0:2)
    double precision :: cx(0:2), cy(0:2), cz(0:2)

    if (.not. turbinflow_initialized) call bl_error("turbinflow module uninitialized")

    if (z.lt.szlo+0.5d0*dx(3) .or. z.gt.szhi-0.5d0*dx(3)) then
       call store_planes(z)
    end if

    zz = (z-szlo)*dxinv(3)
    k0 = nint(zz) - 1
    zz = zz - dble(k0)
    cz(0) = 0.5d0*(zz-1.d0)*(zz-2.d0)
    cz(1) = zz*(2.d0-zz)
    cz(2) = 0.5d0*zz*(zz-1.d0)
    k0 = k0 + 1 ! because it's Fortran
    k0 = min(max(k0,1),nplane-2)

    do n=1,3
       do j=lo2,hi2
          yy = (y(j)-pboxlo(2))*dxinv(2)
          j0 = nint(yy) - 1
          yy = yy - dble(j0)
          cy(0) = 0.5d0*(yy-1.d0)*(yy-2.d0)
          cy(1) = yy*(2.d0-yy)
          cy(2) = 0.5d0*yy*(yy-1.d0)
          j0 = modulo(j0, npboxcells(2)) + 2 ! +2 because Fortran index starts with 1 and there is a ghost point
          do i=lo1,hi1
             xx = (x(i)-pboxlo(1))*dxinv(1)
             i0 = nint(xx) - 1
             xx = xx - dble(i0)
             cx(0) = 0.5d0*(xx-1.d0)*(xx-2.d0)
             cx(1) = xx*(2.d0-xx)
             cx(2) = 0.5d0*xx*(xx-1.d0)
             i0 = modulo(i0, npboxcells(1)) + 2 ! +2 as j0

             do jj=0,2
                do ii=0,2
                   zdata(ii,jj) = cz(0)*sdata(i0+ii,j0+jj,k0  ,n) &
                        +         cz(1)*sdata(i0+ii,j0+jj,k0+1,n) &
                        +         cz(2)*sdata(i0+ii,j0+jj,k0+2,n)
                end do
             end do

             do ii=0,2
                ydata(ii) = cy(0)*zdata(ii,0) + cy(1)*zdata(ii,1) + cy(2)*zdata(ii,2)
             end do

             v(i,j,n) = cx(0)*ydata(0) + cx(1)*ydata(1) + cx(2)*ydata(2)

          end do
       end do
    end do

  end subroutine get_turbvelocity

  subroutine store_planes(z)
    double precision, intent(in) :: z
    integer :: izlo, iplane, k, n
    izlo = nint(z*dxinv(3)) - 1
    szlo = izlo*dx(3)
    szhi = szlo + dble(nplane-1)*dx(3)
    do n=1,3
       do iplane=1,nplane
          k = modulo(izlo+iplane-1, npboxcells(3)) + 1
          call getplane(iturbfile, lenfname, sdata(:,:,iplane,n), k, n, isswirltype)
          sdata(:,:,iplane,n) = sdata(:,:,iplane,n)*units_conversion
       end do
    end do
  end subroutine store_planes

end module turbinflow_module


      subroutine GSRBHELMHOLTZVC3D(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1,iaCoeflo2
     &           ,iaCoefhi0,iaCoefhi1,iaCoefhi2
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
     &           ,ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
     &           ,ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
     &           ,nbCoef1comp
     &           ,bCoef2
     &           ,ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
     &           ,ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
     &           ,nbCoef2comp
     &           ,lambda
     &           ,ilambdalo0,ilambdalo1,ilambdalo2
     &           ,ilambdahi0,ilambdahi1,ilambdahi2
     &           ,nlambdacomp
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1,iaCoeflo2
      integer iaCoefhi0,iaCoefhi1,iaCoefhi2
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           iaCoeflo2:iaCoefhi2,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
      integer ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           ibCoef0lo2:ibCoef0hi2,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
      integer ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           ibCoef1lo2:ibCoef1hi2,
     &           0:nbCoef1comp-1)
      integer nbCoef2comp
      integer ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
      integer ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
      REAL*8 bCoef2(
     &           ibCoef2lo0:ibCoef2hi0,
     &           ibCoef2lo1:ibCoef2hi1,
     &           ibCoef2lo2:ibCoef2hi2,
     &           0:nbCoef2comp-1)
      integer nlambdacomp
      integer ilambdalo0,ilambdalo1,ilambdalo2
      integer ilambdahi0,ilambdahi1,ilambdahi2
      REAL*8 lambda(
     &           ilambdalo0:ilambdahi0,
     &           ilambdalo1:ilambdahi1,
     &           ilambdalo2:ilambdahi2,
     &           0:nlambdacomp-1)
      integer redBlack
      REAL*8 dxinv,lofphi
      integer n,ncomp,indtot,imin,imax
      integer i,j,k
      ncomp = nphicomp
      if (ncomp .ne. nphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef2comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp - 1
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j  + k
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lofphi =
     &            alpha * aCoef(i,j,k,n) * phi(i,j,k,n)
     &          - beta  *
     &             (
     &               bCoef0(i+1,j  ,k  ,n)
     &               * (phi(i+1,j  ,k  ,n)-phi(i  ,j  ,k  ,n))
     &             - bCoef0(i  ,j  ,k  ,n)
     &               * (phi(i  ,j  ,k  ,n)-phi(i-1,j  ,k  ,n))
     &             + bCoef1(i  ,j+1,k  ,n)
     &               * (phi(i  ,j+1,k  ,n)-phi(i  ,j  ,k  ,n))
     &             - bCoef1(i  ,j  ,k  ,n)
     &               * (phi(i  ,j  ,k  ,n)-phi(i  ,j-1,k  ,n))
     &             + bCoef2(i  ,j  ,k+1,n)
     &               * (phi(i  ,j  ,k+1,n)-phi(i  ,j  ,k  ,n))
     &             - bCoef2(i  ,j  ,k  ,n)
     &               * (phi(i  ,j  ,k  ,n)-phi(i  ,j  ,k-1,n))
     &             ) * dxinv
              phi(i,j,k,n) = phi(i,j,k,n)
     &          - lambda(i,j,k,n) * (lofphi - rhs(i,j,k,n))
            enddo
          enddo
        enddo
      enddo
      return
      end
      subroutine VCCOMPUTEOP3D(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1,ilofphilo2
     &           ,ilofphihi0,ilofphihi1,ilofphihi2
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1,iaCoeflo2
     &           ,iaCoefhi0,iaCoefhi1,iaCoefhi2
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
     &           ,ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
     &           ,ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
     &           ,nbCoef1comp
     &           ,bCoef2
     &           ,ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
     &           ,ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
     &           ,nbCoef2comp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1,ilofphilo2
      integer ilofphihi0,ilofphihi1,ilofphihi2
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           ilofphilo2:ilofphihi2,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1,iaCoeflo2
      integer iaCoefhi0,iaCoefhi1,iaCoefhi2
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           iaCoeflo2:iaCoefhi2,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
      integer ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           ibCoef0lo2:ibCoef0hi2,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
      integer ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           ibCoef1lo2:ibCoef1hi2,
     &           0:nbCoef1comp-1)
      integer nbCoef2comp
      integer ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
      integer ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
      REAL*8 bCoef2(
     &           ibCoef2lo0:ibCoef2hi0,
     &           ibCoef2lo1:ibCoef2hi1,
     &           ibCoef2lo2:ibCoef2hi2,
     &           0:nbCoef2comp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef2comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lofphi(i,j,k,n) =
     &        alpha * aCoef(i,j,k,n) * phi(i,j,k,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,j  ,k  ,n)
     &           * (phi(i+1,j  ,k  ,n) - phi(i  ,j  ,k  ,n))
     &         - bCoef0(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n) - phi(i-1,j  ,k  ,n))
     &         + bCoef1(i  ,j+1,k  ,n)
     &           * (phi(i  ,j+1,k  ,n) - phi(i  ,j  ,k  ,n))
     &         - bCoef1(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n) - phi(i  ,j-1,k  ,n))
     &         + bCoef2(i  ,j  ,k+1,n)
     &           * (phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k  ,n))
     &         - bCoef2(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n) - phi(i  ,j  ,k-1,n))
     &         ) * dxinv
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine VCCOMPUTERES3D(
     &           res
     &           ,ireslo0,ireslo1,ireslo2
     &           ,ireshi0,ireshi1,ireshi2
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1,iaCoeflo2
     &           ,iaCoefhi0,iaCoefhi1,iaCoefhi2
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
     &           ,ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
     &           ,ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
     &           ,nbCoef1comp
     &           ,bCoef2
     &           ,ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
     &           ,ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
     &           ,nbCoef2comp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0,ireslo1,ireslo2
      integer ireshi0,ireshi1,ireshi2
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           ireslo2:ireshi2,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1,iaCoeflo2
      integer iaCoefhi0,iaCoefhi1,iaCoefhi2
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           iaCoeflo2:iaCoefhi2,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
      integer ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           ibCoef0lo2:ibCoef0hi2,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
      integer ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           ibCoef1lo2:ibCoef1hi2,
     &           0:nbCoef1comp-1)
      integer nbCoef2comp
      integer ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
      integer ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
      REAL*8 bCoef2(
     &           ibCoef2lo0:ibCoef2hi0,
     &           ibCoef2lo1:ibCoef2hi1,
     &           ibCoef2lo2:ibCoef2hi2,
     &           0:nbCoef2comp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 dxinv
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      if (ncomp .ne. nrescomp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef0comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef1comp) then
         call MAYDAYERROR()
      endif
      if (ncomp .ne. nbCoef2comp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          res(i,j,k,n) =
     &        rhs(i,j,k,n)
     &      - (alpha * aCoef(i,j,k,n) * phi(i,j,k,n)
     &       - beta  *
     &          (
     &            bCoef0(i+1,j  ,k  ,n)
     &            * (phi(i+1,j  ,k  ,n) - phi(i  ,j  ,k  ,n))
     &          - bCoef0(i  ,j  ,k  ,n)
     &            * (phi(i  ,j  ,k  ,n) - phi(i-1,j  ,k  ,n))
     &          + bCoef1(i  ,j+1,k  ,n)
     &            * (phi(i  ,j+1,k  ,n) - phi(i  ,j  ,k  ,n))
     &          - bCoef1(i  ,j  ,k  ,n)
     &            * (phi(i  ,j  ,k  ,n) - phi(i  ,j-1,k  ,n))
     &          + bCoef2(i  ,j  ,k+1,n)
     &            * (phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k  ,n))
     &          - bCoef2(i  ,j  ,k  ,n)
     &            * (phi(i  ,j  ,k  ,n) - phi(i  ,j  ,k-1,n))
     &          ) * dxinv
     &        )
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine RESTRICTRESVC3D(
     &           res
     &           ,ireslo0,ireslo1,ireslo2
     &           ,ireshi0,ireshi1,ireshi2
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,alpha
     &           ,aCoef
     &           ,iaCoeflo0,iaCoeflo1,iaCoeflo2
     &           ,iaCoefhi0,iaCoefhi1,iaCoefhi2
     &           ,naCoefcomp
     &           ,beta
     &           ,bCoef0
     &           ,ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
     &           ,ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
     &           ,nbCoef0comp
     &           ,bCoef1
     &           ,ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
     &           ,ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
     &           ,nbCoef1comp
     &           ,bCoef2
     &           ,ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
     &           ,ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
     &           ,nbCoef2comp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0,ireslo1,ireslo2
      integer ireshi0,ireshi1,ireshi2
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           ireslo2:ireshi2,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      REAL*8 alpha
      integer naCoefcomp
      integer iaCoeflo0,iaCoeflo1,iaCoeflo2
      integer iaCoefhi0,iaCoefhi1,iaCoefhi2
      REAL*8 aCoef(
     &           iaCoeflo0:iaCoefhi0,
     &           iaCoeflo1:iaCoefhi1,
     &           iaCoeflo2:iaCoefhi2,
     &           0:naCoefcomp-1)
      REAL*8 beta
      integer nbCoef0comp
      integer ibCoef0lo0,ibCoef0lo1,ibCoef0lo2
      integer ibCoef0hi0,ibCoef0hi1,ibCoef0hi2
      REAL*8 bCoef0(
     &           ibCoef0lo0:ibCoef0hi0,
     &           ibCoef0lo1:ibCoef0hi1,
     &           ibCoef0lo2:ibCoef0hi2,
     &           0:nbCoef0comp-1)
      integer nbCoef1comp
      integer ibCoef1lo0,ibCoef1lo1,ibCoef1lo2
      integer ibCoef1hi0,ibCoef1hi1,ibCoef1hi2
      REAL*8 bCoef1(
     &           ibCoef1lo0:ibCoef1hi0,
     &           ibCoef1lo1:ibCoef1hi1,
     &           ibCoef1lo2:ibCoef1hi2,
     &           0:nbCoef1comp-1)
      integer nbCoef2comp
      integer ibCoef2lo0,ibCoef2lo1,ibCoef2lo2
      integer ibCoef2hi0,ibCoef2hi1,ibCoef2hi2
      REAL*8 bCoef2(
     &           ibCoef2lo0:ibCoef2hi0,
     &           ibCoef2lo1:ibCoef2hi1,
     &           ibCoef2lo2:ibCoef2hi2,
     &           0:nbCoef2comp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i,j,k
      integer ii,jj,kk
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2  *2  *2
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/2
          jj = j/2
          kk = k/2
          lofphi =
     &        alpha * aCoef(i,j,k,n) * phi(i,j,k,n)
     &      - beta  *
     &         (
     &           bCoef0(i+1,j  ,k  ,n)
     &           * (phi(i+1,j  ,k  ,n)-phi(i  ,j  ,k  ,n))
     &         - bCoef0(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n)-phi(i-1,j  ,k  ,n))
     &         + bCoef1(i  ,j+1,k  ,n)
     &           * (phi(i  ,j+1,k  ,n)-phi(i  ,j  ,k  ,n))
     &         - bCoef1(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n)-phi(i  ,j-1,k  ,n))
     &         + bCoef2(i  ,j  ,k+1,n)
     &           * (phi(i  ,j  ,k+1,n)-phi(i  ,j  ,k  ,n))
     &         - bCoef2(i  ,j  ,k  ,n)
     &           * (phi(i  ,j  ,k  ,n)-phi(i  ,j  ,k-1,n))
     &         ) * dxinv
          res(ii,jj,kk,n) = res(ii,jj,kk,n)
     &                            + (rhs(i,j,k,n) - lofphi) / denom
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine SUMFACES(
     &           lhs
     &           ,ilhslo0,ilhslo1,ilhslo2
     &           ,ilhshi0,ilhshi1,ilhshi2
     &           ,nlhscomp
     &           ,beta
     &           ,bCoefs
     &           ,ibCoefslo0,ibCoefslo1,ibCoefslo2
     &           ,ibCoefshi0,ibCoefshi1,ibCoefshi2
     &           ,nbCoefscomp
     &           ,iboxlo0,iboxlo1,iboxlo2
     &           ,iboxhi0,iboxhi1,iboxhi2
     &           ,dir
     &           ,scale
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nlhscomp
      integer ilhslo0,ilhslo1,ilhslo2
      integer ilhshi0,ilhshi1,ilhshi2
      REAL*8 lhs(
     &           ilhslo0:ilhshi0,
     &           ilhslo1:ilhshi1,
     &           ilhslo2:ilhshi2,
     &           0:nlhscomp-1)
      REAL*8 beta
      integer nbCoefscomp
      integer ibCoefslo0,ibCoefslo1,ibCoefslo2
      integer ibCoefshi0,ibCoefshi1,ibCoefshi2
      REAL*8 bCoefs(
     &           ibCoefslo0:ibCoefshi0,
     &           ibCoefslo1:ibCoefshi1,
     &           ibCoefslo2:ibCoefshi2,
     &           0:nbCoefscomp-1)
      integer iboxlo0,iboxlo1,iboxlo2
      integer iboxhi0,iboxhi1,iboxhi2
      integer dir
      REAL*8 scale
      REAL*8 sumVal
      integer i,j,k
      integer ii,jj,kk
      integer n
      ii = CHF_ID(0,dir)
      jj = CHF_ID(1,dir)
      kk = CHF_ID(2,dir)
      do n = 0, nlhscomp-1
      do k = iboxlo2,iboxhi2
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          sumVal = bCoefs(i+ii,j+jj,k+kk,n)
     &           + bCoefs(i   ,j   ,k   ,n)
          lhs(i,j,k,n) = lhs(i,j,k,n) + scale * beta * sumVal
      enddo
      enddo
      enddo
      enddo
      return
      end


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE ZINDEX(XA,N,X,INDEX,RINDEX)
*
* Module Number: 13.10.3.1
*
* Module Name: zindex
*
* Keyphrase:
* ----------
* Compute effective index of data value in array
*
* Description:
* ------------
* Using Bisection, the location of a data value is found in an array.
* The index (INDEX) is set to the location where the input X lies
* between XA(INDEX) and XA(INDEX-1).  The effective index (including
* fractions of a data point) is returned in RINDEX.  If X is less than
* the minimum of XA then INDEX is set to 1.  If X is greater than the
* maximum of XA, INDEX is set to N-1.  When X is not in the bounds of
* XA, RINDEX is set to an extrapolated value.
*
* XA must be in ascending order.
*
* Fortran Name: zindex.for
*
* Keywords of accessed files and tables:
* --------------------------------------
*       none
*
* Subroutines Called:
* -------------------
* CDBS:
*       none
* SDAS:
*       none
*
* History:
* --------
* version         date            Author          Description
*    1          3/5/87          D. Lindler      Designed and coded
*    2          DEC 87          D. LINDLER      NEW SDAS STANDARDS
*-------------------------------------------------------------------------
*
* Input parameters
*
*       XA - vector to be searched (real*8)
*       N - number of points in XA (integer)
*       X - value to search for (real*8)
*
* Output parameters
*
*       INDEX - index postion of X (integer)
*       RINDEX - effective index including fractional pixels (real*8)
*
	IMPLICIT NONE
        DOUBLE PRECISION XA(*),X,RINDEX
        INTEGER N,INDEX
*
* local variables
*
        INTEGER HI,LOW
*
*---------------------------------------------------------------------
C
C INITIALIZE HI AND LOW TO END POINTS
C
        LOW=1
        HI=N
C
C BISECT ARRAY AND RESET HI OR LOW DEPENDING ON WHICH SIDE OF THEIR
C CENTER X LIES.
C
C STOP WHEN HI=LOW+1
C
1       IF((HI-LOW).GT.1)THEN
                INDEX=(HI+LOW)/2
                IF(XA(INDEX).GT.X) THEN
                        HI=INDEX
                   ELSE
                        LOW=INDEX
                ENDIF
                GO TO 1
        ENDIF
C
C COMPUTE FRACTIONAL INDEX USING INTERPOLATION
C
        INDEX = LOW
        RINDEX = INDEX + (X-XA(INDEX))/(XA(INDEX+1)-XA(INDEX))
        RETURN
        END


      SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5)
c
c  njtj
c  ###  Cray conversions
c  ###    1)Switch double precision to real.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
C
      INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
      INTEGER IND(M)
      DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
      DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP
      DOUBLE PRECISION ZERO,ONE,TWO,PFIVE
Cray      REAL D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
Cray      REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP
C
      PARAMETER(ZERO=0.D0,ONE=1.D0,TWO=2.D0,PFIVE=0.5D0)
Cray      PARAMETER(ZERO=0.0,ONE=1.0,TWO=2.0,PFIVE=0.5)
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT,
C     NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
C
C     THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
C     SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES,
C     USING BISECTION.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
C          EIGENVALUES.  IF THE INPUT EPS1 IS NON-POSITIVE,
C          IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
C          NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
C          PRECISION AND THE 1-NORM OF THE SUBMATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2(1) IS ARBITRARY,
C
C        M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED
C          EIGENVALUES,
C
C        M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED.  THE UPPER
C          BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1.
C
C     ON OUTPUT-
C
C        EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
C          (LAST) DEFAULT VALUE,
C
C        D AND E ARE UNALTERED,
C
C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
C          E2(1) IS ALSO SET TO ZERO,
C
C        LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED
C          EIGENVALUES,
C
C        W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES
C          BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER,
C
C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          3*N+1      IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE
C                     UNIQUE SELECTION IMPOSSIBLE,
C          3*N+2      IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE
C                     UNIQUE SELECTION IMPOSSIBLE,
C
C        RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
C
C     NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER
C     THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
      MACHEP = TWO**(-40)
C
      IERR = 0
      TAG = 0
      XU = D(1)
      X0 = D(1)
      U = ZERO
C     ********** LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
C                INTERVAL CONTAINING ALL THE EIGENVALUES **********
      DO 40 I = 1, N
         X1 = U
         U = ZERO
         IF (I .NE. N) U = ABS(E(I+1))
         XU = MIN(D(I)-(X1+U),XU)
         X0 = MAX(D(I)+(X1+U),X0)
         IF (I .EQ. 1) GO TO 20
         IF (ABS(E(I)) .GT. MACHEP * (ABS(D(I)) + ABS(D(I-1))))
     X      GO TO 40
   20    E2(I) = ZERO
   40 CONTINUE
C
      X1 = MAX(ABS(XU),ABS(X0)) * MACHEP * REAL(N)
      XU = XU - X1
      T1 = XU
      X0 = X0 + X1
      T2 = X0
C     ********** DETERMINE AN INTERVAL CONTAINING EXACTLY
C                THE DESIRED EIGENVALUES **********
      P = 1
      Q = N
      M1 = M11 - 1
      IF (M1 .EQ. 0) GO TO 75
      ISTURM = 1
   50 V = X1
      X1 = XU + (X0 - XU) * 0.5
      IF (X1 .EQ. V) GO TO 980
      GO TO 320
   60 IF (S - M1) 65, 73, 70
   65 XU = X1
      GO TO 50
   70 X0 = X1
      GO TO 50
   73 XU = X1
      T1 = X1
   75 M22 = M1 + M
      IF (M22 .EQ. N) GO TO 90
      X0 = T2
      ISTURM = 2
      GO TO 50
   80 IF (S - M22) 65, 85, 70
   85 T2 = X1
   90 Q = 0
      R = 0
C     ********** ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C                INTERVAL BY THE GERSCHGORIN BOUNDS **********
  100 IF (R .EQ. M) GO TO 1001
      TAG = TAG + 1
      P = Q + 1
      XU = D(P)
      X0 = D(P)
      U = ZERO
C
      DO 120 Q = P, N
         X1 = U
         U = ZERO
         V = ZERO
         IF (Q .EQ. N) GO TO 110
         U = ABS(E(Q+1))
         V = E2(Q+1)
  110    XU = MIN(D(Q)-(X1+U),XU)
         X0 = MAX(D(Q)+(X1+U),X0)
         IF (V .EQ. 0.0) GO TO 140
  120 CONTINUE
C
  140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
      IF (EPS1 .LE. 0.0) EPS1 = -X1
      IF (P .NE. Q) GO TO 180
C     ********** CHECK FOR ISOLATED ROOT WITHIN INTERVAL **********
      IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
      M1 = P
      M2 = P
      RV5(P) = D(P)
      GO TO 900
  180 X1 = X1 * REAL(Q-P+1)
      LB = MAX(T1,XU-X1)
      UB = MIN(T2,X0+X1)
      X1 = LB
      ISTURM = 3
      GO TO 320
  200 M1 = S + 1
      X1 = UB
      ISTURM = 4
      GO TO 320
  220 M2 = S
      IF (M1 .GT. M2) GO TO 940
C     ********** FIND ROOTS BY BISECTION **********
      X0 = UB
      ISTURM = 5
C
      DO 240 I = M1, M2
         RV5(I) = UB
         RV4(I) = LB
  240 CONTINUE
C     ********** LOOP FOR K-TH EIGENVALUE
C                FOR K=M2 STEP -1 UNTIL M1 DO --
C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) **********
      K = M2
  250    XU = LB
C     ********** FOR I=K STEP -1 UNTIL M1 DO -- **********
         DO 260 II = M1, K
            I = M1 + K - II
            IF (XU .GE. RV4(I)) GO TO 260
            XU = RV4(I)
            GO TO 280
  260    CONTINUE
C
  280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
C     ********** NEXT BISECTION STEP **********
  300    X1 = (XU + X0) * PFIVE
         IF ((X0 - XU) .LE. (TWO * MACHEP *
     X      (ABS(XU) + ABS(X0)) + ABS(EPS1))) GO TO 420
C     ********** IN-LINE PROCEDURE FOR STURM SEQUENCE **********
  320    S = P - 1
         U = ONE
C
         DO 340 I = P, Q
            IF (U .NE. ZERO) GO TO 325
            V = ABS(E(I)) / MACHEP
            IF (E2(I) .EQ. ZERO) V = ZERO
            GO TO 330
  325       V = E2(I) / U
  330       U = D(I) - X1 - V
            IF (U .LT. ZERO) S = S + 1
  340    CONTINUE
C
         GO TO (60,80,200,220,360), ISTURM
C     ********** REFINE INTERVALS **********
  360    IF (S .GE. K) GO TO 400
         XU = X1
         IF (S .GE. M1) GO TO 380
         RV4(M1) = X1
         GO TO 300
  380    RV4(S+1) = X1
         IF (RV5(S) .GT. X1) RV5(S) = X1
         GO TO 300
  400    X0 = X1
         GO TO 300
C     ********** K-TH EIGENVALUE FOUND **********
  420    RV5(K) = X1
      K = K - 1
      IF (K .GE. M1) GO TO 250
C     ********** ORDER EIGENVALUES TAGGED WITH THEIR
C                SUBMATRIX ASSOCIATIONS **********
  900 S = R
      R = R + M2 - M1 + 1
      J = 1
      K = M1
C
      DO 920 L = 1, R
         IF (J .GT. S) GO TO 910
         IF (K .GT. M2) GO TO 940
         IF (RV5(K) .GE. W(L)) GO TO 915
C
         DO 905 II = J, S
            I = L + S - II
            W(I+1) = W(I)
            IND(I+1) = IND(I)
  905    CONTINUE
C
  910    W(L) = RV5(K)
         IND(L) = TAG
         K = K + 1
         GO TO 920
  915    J = J + 1
  920 CONTINUE
C
  940 IF (Q .LT. N) GO TO 100
      GO TO 1001
C     ********** SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
C                EXACTLY THE DESIRED EIGENVALUES **********
  980 IERR = 3 * N + ISTURM
 1001 LB = T1
      UB = T2
      RETURN
C     ********** LAST CARD OF TRIDIB **********
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        SUBROUTINE extrapsh (date, dte1, nmax1, gh1, nmax2,
     1 gh2, nmax, gh)
c ===============================================================
c
c       version 1.01
c
c       extrapolates linearly a spherical harmonic model with a
c       rate-of-change model.
c
c       input:
c           date  - date of resulting model (in decimal year)
c           dte1  - date of base model
c           nmax1 - maximum degree and order of base model
c           gh1   - schmidt quasi-normal internal spherical
c                   harmonic coefficients of base model
c           nmax2 - maximum degree and order of rate-of-change
c                   model
c           gh2   - schmidt quasi-normal internal spherical
c                   harmonic coefficients of rate-of-change model
c
c       output:
c           gh    - coefficients of resulting model
c           nmax  - maximum degree and order of resulting model
c
c       a. zunde
c       usgs, ms 964, box 25046 federal center, denver, co  80225
c
c ===============================================================
        dimension       gh1(*), gh2(*), gh(*)
c ---------------------------------------------------------------
c       the coefficients (gh) of the resulting model, at date
c       date, are computed by linearly extrapolating the coef-
c       ficients of the base model (gh1), at date dte1, using
c       those of the rate-of-change model (gh2), at date dte2. if
c       one model is smaller than the other, the extrapolation is
c       performed with the missing coefficients assumed to be 0.
c ---------------------------------------------------------------
        factor = (date - dte1)
        if (nmax1 .eq. nmax2) then
            k = nmax1 * (nmax1 + 2)
            nmax = nmax1
        else if (nmax1 .gt. nmax2) then
            k = nmax2 * (nmax2 + 2)
            l = nmax1 * (nmax1 + 2)
            do 5 i = k + 1, l
                gh(i) = gh1(i)
   5        continue
            nmax = nmax1
        else
            k = nmax1 * (nmax1 + 2)
            l = nmax2 * (nmax2 + 2)
            do 10 i = k + 1, l
                 gh(i) = factor * gh2(i)
   10       continue
            nmax = nmax2
        endif
        do 15 i = 1, k
            gh(i) = gh1(i) + factor * gh2(i)
   15   continue
        return
        end