!==========================================================================
elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, &
                                                     eta_sa_ct, eta_ct_ct)
! =========================================================================
!
!  Calculates the following three second-order partial derivatives of
!  specific entropy (eta)
!   (1) eta_SA_SA, the second derivative with respect to Absolute
!       Salinity at constant Conservative Temperature, and
!   (2) eta_SA_CT, the derivative with respect to Absolute Salinity and
!       Conservative Temperature.
!   (3) eta_CT_CT, the second derivative with respect to Conservative
!       Temperature at constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!
!  eta_SA_SA =  The second derivative of specific entropy with respect
!               to Absolute Salinity (in units of g kg^-1) at constant
!               Conservative Temperature.
!               eta_SA_SA has units of:                 [ J/(kg K(g/kg)^2)]
!  eta_SA_CT =  The second derivative of specific entropy with respect
!               to Conservative Temperature at constant Absolute
!               Salinity. eta_SA_CT has units of:     [ J/(kg (g/kg) K^2) ]
!  eta_CT_CT =  The second derivative of specific entropy with respect
!               to Conservative Temperature at constant Absolute
!               Salinity.  eta_CT_CT has units of:           [ J/(kg K^3) ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_t0

use gsw_mod_toolbox, only : gsw_gibbs, gsw_pt_from_ct

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct
real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct

real (r8) :: abs_pt, ct_pt, ct_sa, pt, ct_ct

integer, parameter :: n0=0, n1=1, n2=2
real (r8), parameter :: pr0 = 0.0_r8

pt = gsw_pt_from_ct(sa,ct)
abs_pt = gsw_t0 + pt

ct_pt = -(abs_pt*gsw_gibbs(n0,n2,n0,sa,pt,pr0))/gsw_cp0

ct_ct = -gsw_cp0/(ct_pt*abs_pt*abs_pt)

if (present(eta_sa_ct) .or. present(eta_sa_sa)) then

    ct_sa = (gsw_gibbs(n1,n0,n0,sa,pt,pr0) - &
               (abs_pt*gsw_gibbs(n1,n1,n0,sa,pt,pr0)))/gsw_cp0

    if (present(eta_sa_ct)) eta_sa_ct = -ct_sa*ct_ct

    if (present(eta_sa_sa)) eta_sa_sa = -gsw_gibbs(n2,n0,n0,sa,pt,pr0)/abs_pt +&
                                     ct_sa*ct_sa*ct_ct
end if

if (present(eta_ct_ct)) eta_ct_ct = ct_ct

return
end subroutine

!--------------------------------------------------------------------------


C$Procedure      VPRJP ( Vector projection onto plane )

      SUBROUTINE VPRJP ( VIN, PLANE, VOUT )

C$ Abstract
C
C     Project a vector onto a specified plane, orthogonally.
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     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C     VECTOR
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL   =   4 )

      DOUBLE PRECISION      VIN   (    3 )
      DOUBLE PRECISION      PLANE ( UBPL )
      DOUBLE PRECISION      VOUT  (    3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     VIN        I   Vector to be projected.
C     PLANE      I   A SPICELIB plane onto which VIN is projected.
C     VOUT       O   Vector resulting from projection.
C
C$ Detailed_Input
C
C     VIN            is a 3-vector that is to be orthogonally projected
C                    onto a specified plane.
C
C     PLANE          is a SPICELIB plane that represents the geometric
C                    plane onto which VIN is to be projected.
C
C$ Detailed_Output
C
C     VOUT           is the vector resulting from the orthogonal
C                    projection of VIN onto PLANE.  VOUT is the closest
C                    point in the specified plane to VIN.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  Invalid input planes are diagnosed by the routine PL2NVC,
C         which is called by this routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Projecting a vector V orthogonally onto a plane can be thought of
C     as finding the closest vector in the plane to V.  This `closest
C     vector' always exists; it may be coincident with the original
C     vector.
C
C     Two related routines are VPRJPI, which inverts an orthogonal
C     projection of a vector onto a plane, and VPROJ, which projects
C     a vector orthogonally onto another vector.
C
C$ Examples
C
C     1)   Find the closest point in the ring plane of a planet to a
C          spacecraft located at POSITN (in body-fixed coordinates).
C          Suppose the vector NORMAL is normal to the ring plane, and
C          that ORIGIN, which represents the body center, is in the
C          ring plane.  Then we can make a `plane' with the code
C
C             CALL PNV2PL ( ORIGIN, NORMAL, PLANE )
C
C          can find the projection by making the call
C
C             CALL VPRJP ( POSITN, PLANE, PROJ )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     vector projection onto plane
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      DOUBLE PRECISION      VDOT

C
C     Local variables
C
      DOUBLE PRECISION      CONST
      DOUBLE PRECISION      NORMAL ( 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'VPRJP' )
      END IF

C
C     Obtain a unit vector normal to the input plane, and a constant
C     for the plane.
C
      CALL PL2NVC ( PLANE, NORMAL, CONST )

C
C     Let the notation < a, b > indicate the inner product of vectors
C     a and b.
C
C     VIN differs from its projection onto PLANE by some multiple of
C     NORMAL.  That multiple is
C
C
C               < VIN - VOUT, NORMAL >                 *  NORMAL
C
C        =   (  < VIN, NORMAL > - < VOUT, NORMAL >  )  *  NORMAL
C
C        =   (  < VIN, NORMAL > - CONST             )  *  NORMAL
C
C
C     Subtracting this multiple of NORMAL from VIN yields VOUT.
C

      CALL VLCOM (  1.0D0,
     .              VIN,
     .              CONST - VDOT ( VIN, NORMAL ),
     .              NORMAL,
     .              VOUT                          )

      CALL CHKOUT ( 'VPRJP' )
      RETURN
      END


      module NumParams
      use stel_kinds
      integer, parameter :: inescoil = 6
      integer :: inesc = inescoil
      real(rprec), parameter :: zero = 0,
     1    one = 1, two = 2, three = 3,
     2    pi = 3.14159265358979312_dp, pi2 = two*pi, mu0 = 4.0e-7_dp*pi

      contains
        logical function is_zero(x)
        use stel_kinds
        real(rprec) :: x
        is_zero = abs(x) < tiny(x)
        end function is_zero

      end module NumParams


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE DLPARA (X1, Y1, X2, Y2, XM, B, BAD)
C***********************************************************************

C  SUBROUTINE DLPARA = DETERMINES LINE PARAMETERS FROM TWO POINTS

C***********************************************************************

C  SUBROUTINE CALLED BY:
C     INREGN = INPUTS REGION CONNECTIVITIES

C***********************************************************************

C  VARIABLES USED:
C     X1    = X VALUE OF POINT 1
C     X2    = X VALUE OF POINT 2
C     Y1    = Y VALUE OF POINT 1
C     Y2    = Y VALUE OF POINT 2
C     XM    = THE SLOPE OF A STRIGHT LINE BETWEEN POINT 1 AND 2
C     B     = THE Y INTERCEPT OF THE STRAIGHT LINE BETWEEN POINT 1 AND 2

C***********************************************************************

      LOGICAL BAD

      IF (ABS (X2 - X1) .LT. 0.000001) THEN
         BAD = .TRUE.
         B = X1
      ELSE
         BAD = .FALSE.
         XM =  (Y2 - Y1) / (X2 - X1)
         B = Y1- (X1 * XM)
      ENDIF
      RETURN
      END


      program opkdemo8
c-----------------------------------------------------------------------
c Demonstration program for the DLSOIBT package.
c This is the version of 14 June 2001.
c
c This version is in double precision.
c
c This program solves a semi-discretized form of the following system
c Of three PDEs (each similar to a Burgers equation):
c
c   u(i)   =  -(u(1)+u(2)+u(3)) u(i)   +  eta(i) u(i)    (i=1,2,3),
c       t                           x                xx
c
c on the interval  -1 .le. x .le. 1, and with time t .ge. 0.
c The diffusion coefficients are eta(*) = .1, .02, .01.
c The boundary conditions are u(i) = 0 at x = -1 and x = 1 for all i.
c The initial profile for each u(i) is a square wave:
c     u(i) = 0         on 1/2 .lt. abs(x) .le. 1
c     u(i) = amp(i)/2  on abs(x) = 1/2
c     u(i) = amp(i)    on 0 .le. abs(x) .lt. 1/2
c where the amplitudes are amp(*) = .2, .3, .5.
c
c A simplified Galerkin treatment of the spatial variable x is used,
c with piecewise linear basis functions on a uniform mesh of 100
c intervals.  The result is a system of ODEs in the discrete values
c u(i,k) approximating u(i)  (i=1,2,3) at the interior points
c (k = 1,...,99).  The ODEs are:
c
c    .            .        .
c   (u(i,k-1) + 4 u(i,k) + u(i,k+1))/6  =
c
c     -(1/6dx) (c(k-1)dul(i) + 2c(k)(dul(i)+dur(i)) + c(k+1)dur(i))
c
c     + (eta(i)/dx**2) (dur(i) - dul(i))     (i=1,2,3,  k=1,...,99),
c
c where
c     c(j) = u(1,j)+u(2,j)+u(3,j),   dx = .02 = the interval size,
c     dul(i) = u(i,k) - u(i,k-1),   dur(i) = u(i,k+1) - u(i,k).
c Terms involving boundary values (subscripts 0 or 100) are dropped
c from the equations for k = 1 and k = 99 above.
c
c The problem is run for each of the 4 values of mf, and for two values
c of the tolerances.  Output is taken at t = .1, .2, .3, .4.
c Output is on unit lout, set to 6 in a data statement below.
c-----------------------------------------------------------------------
      external res, addabt, jacbt
      integer ncomp, nip, nm1
      integer i, io, istate, itol, iwork, jtol, lout, liw, lrw,
     1   meth, miter, mf, neq, nerr, nint, nout
      double precision eodsq, r6d
      double precision abermx, atol, dx, errfac, eta, hun, one,
     1   rtol, rwork, six, t, tinit, tlast, tout, tols, two, y, ydoti
      dimension eta(3), y(297), ydoti(297), tout(4), tols(2)
      dimension rwork(7447), iwork(317)
      dimension neq(1), rtol(1), atol(1)
c Pass problem parameters in the common block par.
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
c
c Set problem parameters and run parameters
      data eta/0.1d0,0.02d0,0.01d0/, tinit/0.0d0/, tlast/0.4d0/
      data one/1.0d0/, two/2.0d0/, six/6.0d0/, hun/100.0d0/
      data tout/.10d0,.20d0,.30d0,.40d0/
      data lout/6/, nout/4/, lrw/7447/, liw/317/
      data itol/1/, tols/1.0d-3, 1.0d-6/
c
c Set mesh parameters nint, dxc etc.
      nint = 100
      ncomp = 3
      dx = two/nint
      r6d = one/(six*dx)
      do 10 i = 1,ncomp
 10     eodsq(i) = eta(i)/dx**2
      nip = nint - 1
      neq(1) = ncomp*nip
      nm1 = nip - 1
      iwork(1) = ncomp
      iwork(2) = nip
c
      nerr = 0
c
c Set the initial conditions (for output purposes only).
      call setic (nint, ncomp, y)
c
      write (lout,1000)
      write (lout,1100) (eta(i),i=1,ncomp), tinit, tlast, nint,
     1      ncomp, nip, neq(1)
      write (lout,1200)
      call edit (y, ncomp, nip, lout)
c
c The jtol loop is over error tolerances.
      do 200 jtol = 1,2
      rtol(1) = tols(jtol)
      atol(1) = rtol(1)
c
c The meth/miter loops cover 4 values of method flag mf.
      do 100 meth = 1,2
       do 100 miter = 1,2
        mf = 10*meth + miter
c
c Set the initial conditions.
        call setic (nint, ncomp, y)
        t = tinit
        istate = 0
c
        write (lout,1500)  rtol(1), atol(1), mf
c
c Loop over output times for each case
        do 80 io = 1,nout
c
          call dlsoibt (res, addabt,jacbt, neq, y, ydoti, t, tout(io),
     1     itol,rtol,atol, 1, istate, 0, rwork,lrw,iwork,liw, mf)
c
          write (lout,2000) t, rwork(11), iwork(14), iwork(11)
          if (io .eq. nout) call edit (y, ncomp, nip, lout)
c
c If istate is not 2 on return, print message and go to next case.
          if (istate .ne. 2) then
            write (lout,4000) mf, t, istate
            nerr = nerr + 1
            go to 100
            endif
c
 80       continue
c
c Print final statistics.
        write (lout,3000) mf, iwork(11), iwork(12), iwork(13),
     1         iwork(17), iwork(18)
c
c Estimate final error and print result.
        call maxerr (y, ncomp, nip, abermx)
        errfac = abermx/tols(jtol)
        if (errfac .lt. hun) then
          write (lout,5000) errfac
        else
          write (lout,5100) errfac
          nerr = nerr + 1
          endif
 100    continue
 200  continue
c
      write (lout,6000) nerr
c      stop
c
 1000 format(/20x,' Demonstration Problem for DLSOIBT'//
     1   10x,'Galerkin method solution of system of 3 PDEs:'//
     2   10x,'  u(i)   =  -(u(1)+u(2)+u(3)) u(i)   +  eta(i) u(i)',
     3   5x,'(i=1,2,3)',/16x,'t',27x,'x',16x,'xx'//
     4   10x,'x interval is -1 to 1,  zero boundary conditions'/
     5   10x,'x discretized using piecewise linear basis functions')
 1100 format(/10x,'Fixed parameters are as follows:'/
     1       13x,'Diffusion coefficients are eta =',3d10.2/
     2       13x,'t0 = ',d12.5/13x,'tlast = ',d12.5/
     3       13x,'Uniform mesh, number of intervals =',i4/
     4       13x,'Block size mb =',i2/13x,'Number of blocks nb =',i4/
     5       13x,'ODE system size neq =',i5//)
c
 1200 format(/'Initial profiles:'/)
c
 1500 format(////90('*')//'Run with rtol =',d9.1,'  atol =',d9.1,
     1       '   mf =',i3///)
c
 2000 format(' At time t =',d12.5,'  current h =',d12.5,
     1       '  current order =',i2,'  current nst =',i5/)
c
 3000 format(//'Final statistics for mf = ',i2,':',
     1       i5,' steps,',i6,' res,',i6,' jacobians,'/
     2       30x,       'rwork size =',i6,',  iwork size =',i6)
c
 4000 format(//20x,'Final time reached for mf = ',i2,
     1       ' was t = ',d12.5/25x,'at which istate = ',i2//)
 5000 format('Final output is correct to within ',d9.2,
     1       '  times local error tolerance. ')
 5100 format('Final output is wrong by ',d9.2,
     1       '  times local error tolerance.')
 6000 format(//90('*')//'Run completed: ',i3,' errors encountered')
c
c end of main program for the DLSOIBT demonstration problem
      end

      subroutine setic (nint, mb, y)
c This routine loads the y array with initial data based on a
c square wave profile for each of the mb PDE variables.
c
      integer nint, mb, i, k, nip, n14, n34
      double precision y,  amp, half, zero
      dimension y(mb,*), amp(3)
      data zero/0.0d0/, half/0.5d0/, amp/0.2d0,0.3d0,0.5d0/
c
      nip = nint - 1
      n14 = nint/4
      n34 = 3*n14
c
      do 15 k = 1,n14-1
        do 10 i = 1,mb
 10       y(i,k) = zero
 15     continue
c
      do 20 i = 1,mb
 20     y(i,n14) = half*amp(i)
c
      do 35 k = n14+1,n34-1
        do 30 i = 1,mb
 30       y(i,k) = amp(i)
 35     continue
c
      do 40 i = 1,mb
 40     y(i,n34) = half*amp(i)
c
      do 55 k = n34+1,nip
        do 50 i = 1,mb
 50       y(i,k) = zero
 55     continue
c
      return
c end of subroutine setic
      end

      subroutine res (n, t, y, v, r, ires)
c This subroutine computes the residual vector
c   r = g(t,y) - A(t,y)*v
c using routines gfun and subav.
c If ires = -1, only g(t,y) is returned in r, since A(t,y) does
c not depend on y.
c No changes need to be made to this routine if nip is changed.
c
      integer ires, n,  ncomp, nip, nm1
      double precision t, y, v, r, r6d, eodsq
      dimension y(*), v(*), r(*)
      dimension n(*)
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
c
      call gfun (t, y, r, ncomp)
      if (ires .eq. -1) return
c
      call subav (r, v, ncomp)
c
      return
c end of subroutine res
      end

      subroutine gfun (t, y, g, mb)
c This subroutine computes the right-hand side function g(y,t).
c It uses r6d = 1/(6*dx), eodsq(*) = eta(*)/dx**2, nip,
c and nm1 = nip - 1 from the Common block par.
c
      integer mb,  ncomp, nip, nm1,  i, k
      double precision t, y, g,  r6d, eodsq,  cc, cl, cr, dli, dri, two
      dimension g(mb,*), y(mb,*)
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
      data two/2.0d0/
c
c left-most interior point (k = 1)
      cc = y(1,1) + y(2,1) + y(3,1)
      cr = y(1,2) + y(2,2) + y(3,2)
      do 10 i = 1,mb
        dri = y(i,2) - y(i,1)
        g(i,1) = -r6d*(two*cc*y(i,2) + cr*dri)
     1         + eodsq(i)*(dri - y(i,1))
 10     continue
c
c interior points k = 2 to nip-1
      do 20 k = 2,nm1
        cl = y(1,k-1) + y(2,k-1) + y(3,k-1)
        cc = y(1,k) + y(2,k) + y(3,k)
        cr = y(1,k+1) + y(2,k+1) + y(3,k+1)
        do 15 i = 1,mb
          dli = y(i,k) - y(i,k-1)
          dri = y(i,k+1) - y(i,k)
          g(i,k) = -r6d*(cl*dli + two*cc*(dli + dri) + cr*dri)
     1           + eodsq(i)*(dri - dli)
 15       continue
 20     continue
c
c right-most interior point (k = nip)
      cl = y(1,nm1) + y(2,nm1) + y(3,nm1)
      cc = y(1,nip) + y(2,nip) + y(3,nip)
      do 30 i = 1,mb
        dli = y(i,nip) - y(i,nm1)
        g(i,nip) = -r6d*(cl*dli - two*cc*y(i,nm1))
     1           - eodsq(i)*(y(i,nip) + dli)
 30     continue
c
        t = t
      return
c end of subroutine gfun
      end

      subroutine subav (r, v, mb)
c This routine subtracts the matrix a time the vector v from r,
c in order to form the residual vector, stored in r.
c
      integer mb,  ncomp, nip, nm1,  i, k
      double precision r, v,  r6d, eodsq,  aa1, aa4, four, one, six
      dimension r(mb,*), v(mb,*)
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
      data one /1.0d0/, four /4.0d0/, six /6.0d0/
c
      aa1 = one/six
      aa4 = four/six
c
      do 10 i = 1,mb
 10     r(i,1) = r(i,1) - (aa4*v(i,1) + aa1*v(i,2))
c
      do 20 k = 2,nm1
        do 15 i = 1,mb
 15       r(i,k) = r(i,k) - (aa1*v(i,k-1) + aa4*v(i,k) + aa1*v(i,k+1))
 20     continue
c
      do 30 i = 1,mb
 30     r(i,nip) = r(i,nip) - (aa1*v(i,nm1) + aa4*v(i,nip))
c
      return
c end of subroutine subav
      end

      subroutine addabt (n, t, y, mb, nb, pa, pb, pc)
c This subroutine computes the elements of the matrix A,
c and adds them to pa, pb, and pc in the appropriate manner.
c The matrix A is tridiagonal, of order n, with
c nonzero elements (reading across) of 1/6, 4/6, 1/6.
c
      integer n, mb, nb, i, k
      double precision pa, pb, pc, t, y,  aa1, aa4, four, one, six
      dimension y(mb,nb),pa(mb,mb,nb),pb(mb,mb,nb),pc(mb,mb,nb)
      data one/1.0d0/, four/4.0d0/, six/6.0d0/
c
      aa1 = one/six
      aa4 = four/six
      do 50 k = 1,nb
        do 10 i = 1,mb
 10       pa(i,i,k) = pa(i,i,k) + aa4
        if (k .ne. nb) then
          do 20 i = 1,mb
 20         pb(i,i,k) = pb(i,i,k) + aa1
        endif
        if (k .ne. 1) then
          do 30 i = 1,mb
 30         pc(i,i,k) = pc(i,i,k) + aa1
        endif
 50     continue
c
      return
c end of subroutine addabt
      end

      subroutine jacbt (n, t, y, s, mb, nb, pa, pb, pc)
c This subroutine computes the Jacobian dg/dy = d(g-A*s)/dy
c which has block-tridiagonal structure.  The main, upper, and
c lower diagonals are stored in pa, pb, and pc, respectively.
c
      integer n, mb, nb,  ncomp, nip, nm1, i, j, k
      double precision t, y, s, pa, pb, pc,  r6d, eodsq,  cc, cl, cr,
     1   dlj, drj, paij, pbij, pcij, terma, termb, termc, two
      dimension y(mb,nb),s(n),pa(mb,mb,nb),pb(mb,mb,nb),pc(mb,mb,nb)
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
      data two/2.0d0/
c
c left-most interior point (k = 1)
      cc = y(1,1) + y(2,1) + y(3,1)
      cr = y(1,2) + y(2,2) + y(3,2)
      terma = r6d*cr
      termb = -r6d*(two*cc + cr)
      do 20 j = 1,mb
        drj = y(j,2) - y(j,1)
        paij = -r6d*two*y(j,2)
        pbij = -r6d*drj
        do 10 i = 1,mb
          pa(i,j,1) = paij
 10       pb(i,j,1) = pbij
        pa(j,j,1) = pa(j,j,1) + terma - two*eodsq(j)
        pb(j,j,1) = pb(j,j,1) + termb + eodsq(j)
 20     continue
c
c interior points k = 2 to nip-1
      do 50 k = 2,nm1
        cl = y(1,k-1) + y(2,k-1) + y(3,k-1)
        cc = y(1,k) + y(2,k) + y(3,k)
        cr = y(1,k+1) + y(2,k+1) + y(3,k+1)
        terma = r6d*(cr - cl)
        termb = -r6d*(two*cc + cr)
        termc = r6d*(two*cc + cl)
        do 40 j = 1,mb
          dlj = y(j,k) - y(j,k-1)
          drj = y(j,k+1) - y(j,k)
          paij = -r6d*two*(dlj + drj)
          pbij = -r6d*drj
          pcij = -r6d*dlj
          do 30 i = 1,mb
            pa(i,j,k) = paij
            pb(i,j,k) = pbij
 30         pc(i,j,k) = pcij
          pa(j,j,k) = pa(j,j,k) + terma - two*eodsq(j)
          pb(j,j,k) = pb(j,j,k) + termb + eodsq(j)
          pc(j,j,k) = pc(j,j,k) + termc + eodsq(j)
 40       continue
 50     continue
c
c right-most interior point (k = nip)
      cl = y(1,nm1) + y(2,nm1) + y(3,nm1)
      cc = y(1,nip) + y(2,nip) + y(3,nip)
      terma = -r6d*cl
      termc = r6d*(two*cc + cl)
      do 70 j = 1,mb
        dlj = y(j,nip) - y(j,nm1)
        paij = r6d*two*y(j,nm1)
        pcij = -r6d*dlj
        do 60 i = 1,mb
          pa(i,j,nip) = paij
 60       pc(i,j,nip) = pcij
        pa(j,j,nip) = pa(j,j,nip) + terma - two*eodsq(j)
        pc(j,j,nip) = pc(j,j,nip) + termc + eodsq(j)
 70     continue
c
      return
c end of subroutine jacbt
      end

      subroutine edit (y, mb, nip, lout)
c This routine prints output.  For each of the mb PDE components, the
c values at the nip points are printed.  All output is on unit lout.
c
      integer mb, nip, lout,  i, k
      double precision y
      dimension y(mb,nip)
c
      do 10 i = 1,mb
 10      write (lout,20) i, (y(i,k),k=1,nip)
c
 20   format(' Values of PDE component i =',i3/15(7d12.4/))
c
      return
c end of subroutine edit
      end

      subroutine maxerr (y, mb, nb, abermx)
c This routine computes the maximum absolute error in the y array,
c as a computed solution at t = 0.4, using data-loaded values for
c accurate answers (from running with much smaller tolerances).
c
      integer mb, nb,  k
      double precision y, abermx,  ae1, ae2, ae3, u1, u2, u3, zero
c     1   u1a, u1b, u1c, u1d, u1e, u1f, u1g,
c     2   u2a, u2b, u2c, u2d, u2e, u2f, u2g,
c     3   u3a, u3b, u3c, u3d, u3e, u3f, u3g
      dimension y(mb,nb), u1(99), u2(99), u3(99)
c      dimension u1a(16),u1b(16),u1c(16),u1d(16),u1e(16),u1f(16),u1g(3),
c     2          u2a(16),u2b(16),u2c(16),u2d(16),u2e(16),u2f(16),u2g(3),
c     3          u3a(16),u3b(16),u3c(16),u3d(16),u3e(16),u3f(16),u3g(3)
c      equivalence (u1a(1),u1(1)), (u1b(1),u1(17)),
c     1      (u1c(1),u1(33)), (u1d(1),u1(49)), (u1e(1),u1(65)),
c     1      (u1f(1),u1(81)), (u1g(1),u1(97))
c      equivalence (u2a(1),u2(1)), (u2b(1),u2(17)),
c     1      (u2c(1),u2(33)), (u2d(1),u2(49)), (u2e(1),u2(65)),
c     1      (u2f(1),u2(81)), (u2g(1),u2(97))
c      equivalence (u3a(1),u3(1)), (u3b(1),u3(17)),
c     1      (u3c(1),u3(33)), (u3d(1),u3(49)), (u3e(1),u3(65)),
c     1      (u3f(1),u3(81)), (u3g(1),u3(97))
c
      data u1 /
     1  1.70956682d-03, 3.43398445d-03, 5.18783349d-03, 6.98515842d-03,
     1  8.83921016d-03, 1.07622016d-02, 1.27650806d-02, 1.48573251d-02,
     1  1.70467655d-02, 1.93394396d-02, 2.17394852d-02, 2.42490773d-02,
     1  2.68684152d-02, 2.95957660d-02, 3.24275691d-02, 3.53586054d-02,
     1  3.83822285d-02, 4.14906520d-02, 4.46752791d-02, 4.79270545d-02,
     1  5.12368132d-02, 5.45956048d-02, 5.79949684d-02, 6.14271460d-02,
     1  6.48852271d-02, 6.83632267d-02, 7.18561029d-02, 7.53597274d-02,
     1  7.88708192d-02, 8.23868545d-02, 8.59059616d-02, 8.94268082d-02,
     1  9.29484864d-02, 9.64703968d-02, 9.99921344d-02, 1.03513375d-01,
     1  1.07033760d-01, 1.10552783d-01, 1.14069668d-01, 1.17583246d-01,
     1  1.21091827d-01, 1.24593066d-01, 1.28083828d-01, 1.31560049d-01,
     1  1.35016617d-01, 1.38447256d-01, 1.41844451d-01, 1.45199401d-01,
     1  1.48502033d-01, 1.51741065d-01, 1.54904135d-01, 1.57977973d-01,
     1  1.60948623d-01, 1.63801670d-01, 1.66522463d-01, 1.69096305d-01,
     1  1.71508595d-01, 1.73744902d-01, 1.75790974d-01, 1.77632682d-01,
     1  1.79255895d-01, 1.80646319d-01, 1.81789276d-01, 1.82669470d-01,
     1  1.83270725d-01, 1.83575716d-01, 1.83565712d-01, 1.83220322d-01,
     1  1.82517279d-01, 1.81432251d-01, 1.79938706d-01, 1.78007835d-01,
     1  1.75608540d-01, 1.72707519d-01, 1.69269456d-01, 1.65257378d-01,
     1  1.60633244d-01, 1.55358941d-01, 1.49398029d-01, 1.42718981d-01,
     1  1.35301474d-01, 1.27148627d-01, 1.18308730d-01, 1.08905085d-01,
     1  9.91559295d-02, 8.93515884d-02, 7.97824293d-02, 7.06663514d-02,
     1  6.21244732d-02, 5.41994827d-02, 4.68848207d-02, 4.01465202d-02,
     1  3.39357642d-02, 2.81954415d-02, 2.28635569d-02, 1.78750916d-02,
     1  1.31630892d-02, 8.65933391d-03, 4.29480447d-03/
      data u2 /
     1  7.17416019d-06, 1.70782645d-05, 3.31245126d-05, 6.01588363d-05,
     1  1.05339286d-04, 1.79174771d-04, 2.96719122d-04, 4.78862606d-04,
     1  7.53598916d-04, 1.15707860d-03, 1.73420412d-03, 2.53849668d-03,
     1  3.63099110d-03, 5.07800919d-03, 6.94782549d-03, 9.30645443d-03,
     1  1.22130079d-02, 1.57152366d-02, 1.98459102d-02, 2.46205841d-02,
     1  3.00370492d-02, 3.60764461d-02, 4.27057301d-02, 4.98809820d-02,
     1  5.75510102d-02, 6.56607602d-02, 7.41541974d-02, 8.29764928d-02,
     1  9.20754824d-02, 1.01402468d-01, 1.10912474d-01, 1.20564094d-01,
     1  1.30319039d-01, 1.40141489d-01, 1.49997326d-01, 1.59853293d-01,
     1  1.69676126d-01, 1.79431680d-01, 1.89084097d-01, 1.98595037d-01,
     1  2.07923034d-01, 2.17023055d-01, 2.25846345d-01, 2.34340694d-01,
     1  2.42451240d-01, 2.50121934d-01, 2.57297724d-01, 2.63927433d-01,
     1  2.69967170d-01, 2.75383917d-01, 2.80158840d-01, 2.84289739d-01,
     1  2.87792167d-01, 2.90698875d-01, 2.93057586d-01, 2.94927384d-01,
     1  2.96374262d-01, 2.97466488d-01, 2.98270390d-01, 2.98847025d-01,
     1  2.99249945d-01, 2.99524080d-01, 2.99705593d-01, 2.99822450d-01,
     1  2.99895431d-01, 2.99939301d-01, 2.99963931d-01, 2.99975129d-01,
     1  2.99974996d-01, 2.99961526d-01, 2.99927041d-01, 2.99854809d-01,
     1  2.99712769d-01, 2.99442742d-01, 2.98942676d-01, 2.98038511d-01,
     1  2.96441259d-01, 2.93684573d-01, 2.89040478d-01, 2.81421884d-01,
     1  2.69315148d-01, 2.50874185d-01, 2.24457680d-01, 1.89885662d-01,
     1  1.49894358d-01, 1.09927672d-01, 7.54041273d-02, 4.90259517d-02,
     1  3.06080023d-02, 1.85165524d-02, 1.09104125d-02, 6.27726960d-03,
     1  3.53002680d-03, 1.94049735d-03, 1.04218859d-03, 5.45964314d-04,
     1  2.77379128d-04, 1.33343739d-04, 5.32660444d-05/
      data u3 /
     1  1.86765383d-10, 1.96772458d-09, 1.19111389d-08, 5.54964761d-08,
     1  2.18340713d-07, 7.55899524d-07, 2.35604385d-06, 6.70801745d-06,
     1  1.76224112d-05, 4.30351929d-05, 9.82592148d-05, 2.10736217d-04,
     1  4.26209304d-04, 8.15657041d-04, 1.48160943d-03, 2.56186555d-03,
     1  4.22851247d-03, 6.68078970d-03, 1.01317466d-02, 1.47903961d-02,
     1  2.08424987d-02, 2.84336008d-02, 3.76573037d-02, 4.85502549d-02,
     1  6.10936693d-02, 7.52198901d-02, 9.08218891d-02, 1.07763660d-01,
     1  1.25889931d-01, 1.45034247d-01, 1.65025016d-01, 1.85689556d-01,
     1  2.06856371d-01, 2.28356037d-01, 2.50021072d-01, 2.71685149d-01,
     1  2.93181998d-01, 3.14344301d-01, 3.35002907d-01, 3.54986687d-01,
     1  3.74123404d-01, 3.92241969d-01, 4.09176451d-01, 4.24772089d-01,
     1  4.38893320d-01, 4.51433444d-01, 4.62324969d-01, 4.71549073d-01,
     1  4.79142163d-01, 4.85197409d-01, 4.89859810d-01, 4.93314543d-01,
     1  4.95770115d-01, 4.97439231d-01, 4.98520996d-01, 4.99187563d-01,
     1  4.99576941d-01, 4.99791928d-01, 4.99903753d-01, 4.99958343d-01,
     1  4.99983239d-01, 4.99993785d-01, 4.99997902d-01, 4.99999367d-01,
     1  4.99999835d-01, 4.99999965d-01, 4.99999995d-01, 5.00000000d-01,
     1  5.00000000d-01, 4.99999997d-01, 4.99999976d-01, 4.99999863d-01,
     1  4.99999315d-01, 4.99996914d-01, 4.99987300d-01, 4.99951740d-01,
     1  4.99829328d-01, 4.99435130d-01, 4.98245007d-01, 4.94883400d-01,
     1  4.86081966d-01, 4.65174923d-01, 4.21856650d-01, 3.47885738d-01,
     1  2.49649938d-01, 1.51648615d-01, 7.80173239d-02, 3.47983164d-02,
     1  1.38686441d-02, 5.05765688d-03, 1.71052539d-03, 5.38966324d-04,
     1  1.57923694d-04, 4.27352191d-05, 1.05512005d-05, 2.33068621d-06,
     1  4.45404604d-07, 6.88336884d-08, 7.23875975d-09/
      data zero/0.0d0/
c
      abermx = zero
      do 10 k = 1,99
        ae1 = abs(y(1,k) - u1(k))
        ae2 = abs(y(2,k) - u2(k))
        ae3 = abs(y(3,k) - u3(k))
        abermx = max(abermx, ae1, ae2, ae3)
 10     continue
c
      return
c end of subroutine maxerr
      end


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     PROGRAM TO ILLUSTRATE THE USE OF HSTPLR TO SOLVE THE EQUATION
C
C     (1/R)(D/DR)(R*DU/DR) + (1/R**2)(D/DTHETA)(DU/DTHETA) = 16*R**2
C
C     ON THE QUARTER-DISK 0 .LT. R .LT. 1 AND 0 .LT. THETA .LT. PI/2
C     WITH THE BOUNDARY CONDITIONS
C
C     U(1,THETA) = 1 - COS(4*THETA)  FOR  0 .LE. THETA .LE. PI/2
C
C     AND
C
C     (DU/DR)(R,0) = (DU/DR)(R,PI/2) = 0  FOR  O .LT. R .LT. 1 .
C
C     NOTE THAT U AT THE ORIGIN IS UNSPECIFIED.  THE EXACT SOLUTION TO
C     THIS PROBLEM IS
C
C               U(R,THETA) = (R**4)(1-COS(4*THETA)) .
C
C     WE WILL USE 50 UNKNOWNS IN THE R-INTERVAL AND 48 UNKNOWNS IN
C     THE THETA-INTERVAL.
C
      DIMENSION       F(51,50)   ,BDB(48)    ,BDC(50)    ,BDD(50)    ,
     1                W(1092)    ,R(50)      ,THETA(48)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF.  ALSO NOTE THAT W
C     IS DIMENSIONED (13 + LOG2(N))*M + 4*N .
C
      IDIMF = 51
      A = 0.
      B = 1.
      M = 50
      MBDCND = 5
      C = 0.
      PI = PIMACH(DUM)
      D = PI/2.
      N = 48
      NBDCND = 3
      ELMBDA = 0.
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION.
C
      DO 101 I=1,M
         R(I) = (FLOAT(I)-0.5)/50.
  101 CONTINUE
      DO 102 J=1,N
         THETA(J) = (FLOAT(J)-0.5)*PI/96.
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 J=1,N
         BDB(J) = 1.-COS(4.*THETA(J))
  103 CONTINUE
      DO 104 I=1,M
         BDC(I) = 0.
         BDD(I) = 0.
  104 CONTINUE
C
C     BDA IS A DUMMY VARIABLE.
C
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 106 I=1,M
         DO 105 J=1,N
            F(I,J) = 16.*R(I)**2
  105    CONTINUE
  106 CONTINUE
      CALL HSTPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C
C                U(R,THETA) = R**4*(1 - COS(4*THETA))
C
      ERR = 0.
      DO 108 I=1,M
         DO 107 J=1,N
            Z = ABS(F(I,J)-R(I)**4*(1.-COS(4.*THETA(J))))
            IF (Z .GT. ERR) ERR = Z
  107    CONTINUE
  108 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HSTPLR EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 1.13038E-03/
     4        12X,33HREQUIRED LENGTH OF W ARRAY = 1042//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F5.0)
C
      END


program assoc_leg_pol_test
  use special_functions
  integer, parameter :: num_pts = 100, lmax=4
  real(kind=dp) :: alp(num_pts, 0:lmax,-lmax:lmax), x_pts(num_pts)
  integer :: i, j, k
  character :: m

  x_pts = [ (-1+2*float(i)/(num_pts-1), i=0, 99) ]

  call gen_assoc_legendre_pol(x_pts, num_pts, lmax, alp)

  do i=1,num_pts
    print '(6f10.4)', x_pts(i), alp(i, :, 1)
  end do
end program assoc_leg_pol_test


subroutine lininterp (arrin, nxin, incin, xin, &
                      arrout, nxout, incout, xout, periodic)
  use shr_kind_mod, only: r8 => shr_kind_r8

!-----------------------------------------------------------------------
!
! Do a linear interpolation from input mesh defined by xin to output
! mesh defined by xout.  Where extrapolation is necessary, values will
! be copied from the extreme edge of the input grid.
!
!---------------------------Code history--------------------------------
!
! Original version:  J. Rosinski
!
!-----------------------------------------------------------------------
  implicit none
!-----------------------------------------------------------------------
!
! Arguments
!
  integer nxin, incin
  integer nxout, incout

  real(r8) xin(nxin), xout(nxout)
  real(r8) arrin(incin,nxin)
  real(r8) arrout(incout,nxout)

  logical periodic
!
! Local workspace
!
  integer i, ii                ! input grid indices
  integer im, ip, iiprev       ! input grid indices
  integer icount               ! number of values

  real(r8) extrap                ! percent grid non-overlap
  real(r8) dxinwrap              ! delta-x on input grid for 2-pi
  real(r8) avgdxin               ! avg input delta-x
  real(r8) ratio                 ! compare dxinwrap to avgdxin
!
! Dynamic
!
  integer iim(nxout)           ! interp. indices minus
  integer iip(nxout)           ! interp. indices plus

  real(r8) wgtm(nxout)           ! interp. weight minus
  real(r8) wgtp(nxout)           ! interp. weight plus
!
! Just copy the data and return if input dimensions are 1
!
  if (nxin.eq.1 .and. nxout.eq.1) then
    arrout(1,1) = arrin(1,1)
  else if (nxin.eq.1) then
    write(6,*)'LININTERP: Must have at least 2 input points'
    call abort
  end if
  icount = 0
  do i=1,nxin-1
    if (xin(i).gt.xin(i+1)) icount = icount + 1
  end do
  do i=1,nxout-1
    if (xout(i).gt.xout(i+1)) icount = icount + 1
  end do
  if (icount.gt.0) then
    write(6,*)'LININTERP: Non-monotonic coordinate array(s) found'
    call abort
  end if
!
! Initialize index arrays for later checking
!
  do i=1,nxout
    iim(i) = 0
    iip(i) = 0
  end do
  if (periodic) then
!
! Periodic case: for values which extend beyond boundaries, assume
! periodicity and interpolate between endpoints.  First check for sane
! periodicity assumption.
!
    if (xin(1).lt.0. .or. xin(nxin).gt.360.) then
      write(6,*)'LININTERP: For periodic Input x-grid must be between 0 and 360'
      call abort
    end if
    if (xout(1).lt.0. .or. xout(nxout).gt.360.) then
      write(6,*)'Output x-grid must be between 0 and 360'
      call abort
    end if
    dxinwrap = xin(1) + 360. - xin(nxin)
    avgdxin = (xin(nxin)-xin(1))/(nxin-1.)
    ratio = dxinwrap/avgdxin
    if (ratio.lt.0.9 .or. ratio.gt.1.1) then
      write(6,*)'LININTERP: Insane dxinwrap value =',dxinwrap,' avg=', avgdxin
      call abort
    end if
    do im=1,nxout
      if (xout(im).gt.xin(1)) exit
      iim(im) = nxin
      iip(im) = 1
      wgtm(im) = (xin(1)        - xout(im)) /dxinwrap
      wgtp(im) = (xout(im)+360. - xin(nxin))/dxinwrap
    end do
    do ip=nxout,1,-1
      if (xout(ip).le.xin(nxin)) exit
      iim(ip) = nxin
      iip(ip) = 1
      wgtm(ip) = (xin(1)+360. - xout(ip)) /dxinwrap
      wgtp(ip) = (xout(ip)    - xin(nxin))/dxinwrap
    end do
  else
!
! Non-periodic case: for values which extend beyond boundaries, set weights
! such that values will just be copied.
!
    do im=1,nxout
      if (xout(im).gt.xin(1)) exit
      iim(im) = 1
      iip(im) = 1
      wgtm(im) = 1.
      wgtp(im) = 0.
    end do
    do ip=nxout,1,-1
      if (xout(ip).le.xin(nxin)) exit
      iim(ip) = nxin
      iip(ip) = nxin
      wgtm(ip) = 1.
      wgtp(ip) = 0.
    end do
  end if
!
! Loop though output indices finding input indices and weights
!
  iiprev = 1
  do i=im,ip
    do ii=iiprev,nxin-1
      if (xout(i).gt.xin(ii) .and. xout(i).le.xin(ii+1)) then
        iim(i) = ii
        iip(i) = ii + 1
        wgtm(i) = (xin(ii+1)-xout(i))/(xin(ii+1)-xin(ii))
        wgtp(i) = (xout(i)-xin(ii))/(xin(ii+1)-xin(ii))
        goto 30
      end if
    end do
    write(6,*)'LININTERP: Failed to find interp values'
30  iiprev = ii
  end do
!
! Check grid overlap
!
  extrap = 100.*((im - 1.) + (nxout - ip))/nxout
  if (extrap.gt.30.) then
    write(6,*)'********LININTERP WARNING:',extrap,' % of output', &
              ' grid will have to be extrapolated********'
  end if
!
! Check that interp/extrap points have been found for all outputs
!
  icount = 0
  do i=1,nxout
    if (iim(i).eq.0 .or. iip(i).eq.0) icount = icount + 1
  end do
  if (icount.gt.0) then
    write(6,*)'LININTERP: Point found without interp indices'
    call abort
  end if
!
! Do the interpolation
!
  do i=1,nxout
    arrout(1,i) = arrin(1,iim(i))*wgtm(i) + arrin(1,iip(i))*wgtp(i)
  end do
  return
end subroutine lininterp


       subroutine smooth_box_3d(a,ni,nj,nk,kernsize)

!      3D smoother using a box filter

       real a(ni,nj,nk)

       real a_2d(ni,nj)

       idelt = kernsize / 2

       do k = 1,nk
           do i = 1,ni
           do j = 1,nj
               il = max(i-idelt,1)
               ih = min(i+idelt,ni)
               jl = max(j-idelt,1)
               jh = min(j+idelt,nj)

               isum = 0
               sum = 0.

               do ii = il,ih
               do jj = jl,jh
                   isum = isum + 1
                   sum = sum + a(ii,jj,k)
               enddo ! jj
               enddo ! ii

               a_2d(i,j) = sum / float(isum)

           enddo ! j
           enddo ! i

           a(:,:,k) = a_2d(:,:)

       enddo ! k

       return
       end


      SUBROUTINE MA01BD( BASE, LGBAS, K, S, A, INCA, ALPHA, BETA, SCAL )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the general product of K real scalars without over-
C     or underflow.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     BASE    (input)  DOUBLE PRECISION
C             Machine base.
C
C     LGBAS   (input)  DOUBLE PRECISION
C             Logarithm of BASE.
C
C     K       (input)  INTEGER
C             The number of scalars.  K >= 1.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     A       (input)  DOUBLE PRECISION array, dimension (K)
C             Vector of real scalars.
C
C     INCA    (input)  INTEGER
C             Increment for the array A. INCA <> 0.
C
C     ALPHA   (output)  DOUBLE PRECISION
C             ALPHA is a real scalar such that
C
C                ALPHA / BETA * BASE**(SCAL)
C
C             is the general product of the scalars in the array A.
C
C     BETA    (output)  DOUBLE PRECISION
C             BETA is either 0.0 or 1.0.
C             See also the description of ALPHA.
C
C     SCAL    (output)  INTEGER
C             Scaling factor exponent, see ALPHA.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, June 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     July 2009, SLICOT Library version of the routine PLAPR1.
C     V. Sima, Aug. 2011, Apr. 2020.
C
C     KEYWORDS
C
C     Computer arithmetic, overflow, underflow.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INCA, K, SCAL
      DOUBLE PRECISION  ALPHA, BASE, BETA, LGBAS
C     .. Array Arguments ..
      INTEGER           S(*)
      DOUBLE PRECISION  A(*)
C     .. Local Scalars ..
      INTEGER           I, SL
      DOUBLE PRECISION  TEMP
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, LOG, MOD
C
C     .. Executable Statements ..
C
      ALPHA = ONE
      BETA  = ONE
      SCAL  = 0
C
      DO 10  I = 1, K
         TEMP = A( 1 + ( I - 1 )*INCA )
         IF ( TEMP.NE.ZERO ) THEN
            SL   = INT( LOG( ABS( TEMP ) ) / LGBAS )
            TEMP = TEMP / BASE / ( BASE**DBLE( SL-1 ) )
         ELSE
            SL   = 0
         END IF
         IF ( S(I).EQ.1 ) THEN
            ALPHA = ALPHA * TEMP
            SCAL  = SCAL + SL
         ELSE
            BETA = BETA * TEMP
            SCAL = SCAL - SL
         END IF
         IF ( MOD( I, 10 ).EQ.0 ) THEN
            IF ( ALPHA.NE.ZERO ) THEN
               SL    = INT( LOG( ABS( ALPHA ) ) / LGBAS )
               SCAL  = SCAL + SL
               ALPHA = ALPHA / BASE / ( BASE**DBLE( SL-1 ) )
            END IF
            IF ( BETA.NE.ZERO ) THEN
               SL   = INT( LOG( ABS( BETA ) ) / LGBAS )
               SCAL = SCAL - SL
               BETA = BETA / BASE / ( BASE**DBLE( SL-1 ) )
            END IF
         END IF
   10 CONTINUE
C
      IF ( BETA.NE.ZERO ) THEN
         ALPHA = ALPHA / BETA
         BETA  = ONE
      END IF
      IF ( ALPHA.EQ.ZERO ) THEN
         SCAL = 0
      ELSE
         SL    = INT( LOG( ABS( ALPHA ) ) / LGBAS )
         ALPHA = ALPHA / BASE / ( BASE**DBLE( SL-1 ) )
         SCAL  = SCAL + SL
      END IF
C
      RETURN
C *** Last line of MA01BD ***
      END


      SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the normal rank of the transfer-function matrix of a
C     state-space model (A,B,C,D).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to balance the compound
C             matrix (see METHOD) as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of state variables, i.e., the order of the
C             matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input) COMPLEX*16 array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state dynamics matrix A of the system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) COMPLEX*16 array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B of the system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) COMPLEX*16 array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C of the system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) COMPLEX*16 array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             direct transmission matrix D of the system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     RANK    (output) INTEGER
C             The normal rank of the transfer-function matrix.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
C             then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*N+MAX(M,P)+1)
C
C     DWORK   DOUBLE PRECISION array, dimension (2*MAX(M,P))
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.
C             LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1,
C                                         MIN(P,N) + MAX(3*P-1,N+P,N+M))
C             For optimum performance LZWORK should be larger.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine reduces the (N+P)-by-(M+N) compound matrix (B  A)
C                                                            (D  C)
C
C     to one with the same invariant zeros and with D of full row rank.
C     The normal rank of the transfer-function matrix is the rank of D.
C
C     REFERENCES
C
C     [1] Svaricek, F.
C         Computation of the Structural Invariants of Linear
C         Multivariable Systems with an Extended Version of
C         the Program ZEROS.
C         System & Control Letters, 6, pp. 261-266, 1985.
C
C     [2] Emami-Naeini, A. and Van Dooren, P.
C         Computation of Zeros of Linear Multivariable Systems.
C         Automatica, 18, pp. 415-430, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable (see [2] and [1]).
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Dec. 2008.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009,
C     Apr. 2009.
C
C     KEYWORDS
C
C     Multivariable system, unitary transformation,
C     structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL
      INTEGER           INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      COMPLEX*16        A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*)
      DOUBLE PRECISION  DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LQUERY
      INTEGER           I, KW, MU, NINFZ, NKROL, NM, NP, NU, RO,
     $                  SIGMA, WRKOPT
      DOUBLE PRECISION  MAXRED, SVLMAX, THRESH, TOLER
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, ZLANGE
      EXTERNAL          DLAMCH, LSAME, ZLANGE
C     .. External Subroutines ..
      EXTERNAL          AB8NXZ, TB01IZ, XERBLA, ZLACPY
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      NP = N + P
      NM = N + M
      INFO = 0
      LEQUIL = LSAME( EQUIL, 'S' )
      LQUERY = ( LZWORK.EQ.-1 )
      WRKOPT = NP*NM
C
C     Test the input scalar arguments.
C
      IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE
         KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1,
     $                      MIN( P, N ) + MAX( 3*P-1, NP, NM ) )
         IF( LQUERY ) THEN
            SVLMAX = ZERO
            NINFZ  = 0
            CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ),
     $                   NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK,
     $                   DWORK, ZWORK, -1, INFO )
            WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) )
         ELSE IF( LZWORK.LT.KW ) THEN
            INFO = -17
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB08MZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         ZWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( M, P ).EQ.0 ) THEN
         RANK = 0
         ZWORK(1) = ONE
         RETURN
      END IF
C
      DO 10 I = 1, 2*N+1
         IWORK(I) = 0
   10 CONTINUE
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of workspace needed at that point in the code,
C     as well as the preferred amount for good performance.)
C
C     Construct the compound matrix  ( B  A ), dimension (N+P)-by-(M+N).
C                                    ( D  C )
C     Complex workspace: need   (N+P)*(N+M).
C
      CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP )
      CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP )
      CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP )
      CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP )
C
C     If required, balance the compound matrix (default MAXRED).
C     Real Workspace: need   N.
C
      KW = WRKOPT + 1
      IF ( LEQUIL ) THEN
         MAXRED = ZERO
         CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK,
     $                NP, ZWORK(NP*M+N+1), NP, DWORK, INFO )
      END IF
C
C     If required, set tolerance.
C
      THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' )
      TOLER = TOL
      IF ( TOLER.LT.THRESH ) TOLER = THRESH
      SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK )
C
C     Reduce this system to one with the same invariant zeros and with
C     D full row rank MU (the normal rank of the original system).
C     Real workspace:    need   2*MAX(M,P);
C     Complex workspace: need   (N+P)*(N+M) +
C                               MAX( 1, MIN(P,M) + MAX(3*M-1,N),
C                                       MIN(P,N) + MAX(3*P-1,N+P,N+M) );
C                        prefer larger.
C     Integer workspace: 2*N+MAX(M,P)+1.
C
      RO = P
      SIGMA = 0
      NINFZ = 0
      CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK,
     $             IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2),
     $             DWORK, ZWORK(KW), LZWORK-KW+1, INFO )
      RANK = MU
C
      ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 )
      RETURN
C *** Last line of AB08MZ ***
      END


	SUBROUTINE DEGRADE_TO_CONSTANT_RESOLUTION(X,Y,N,S,S0,YS)

c	Degrades high resolution sed in (x,y) to a lower resolution
c	(of constant sigma S in wavelength) by applying a gaussian broadening function.

c	S0 = resolution (sigma) in Angstrom of input sed.

c	Returns smoothed spectrum in array (x,ys)

c	Array declaration
	real x(n),y(n),ys(n),s0(n),u(10000),g(10000)

c	Number of sigmas to perform integration
	m=6

c	Compute resulting sigma
	do i=1,n
	sigma=s
	if (sigma.le.s0(i)) then
c		write (6,*) 'sigma < sigma_model',sigma,s0(i)
c		stop
		ys(i)=y(i)
	else
		sigma=sqrt(sigma**2-s0(i)**2)
		xmax=x(i)+m*sigma
		call locate(x,n,xmax,i1)
		m2=i1+1
		m1=2*i-m2
c		write (81,*) i,x(i),sigma,xmax,m1,m2
		if (m1.lt.1) m1=1
		if (m2.gt.n) m2=n
		if (m2-m1+1.lt.10) then
			ys(i)=y(i)
		else
			k=0
			do j=m1,m2
			k=k+1
			u(k)=x(j)
			g(k)=y(j)*gauss(x(j),x(i),sigma)
			enddo
			ys(i)=trapz1(u,g,k)
		endif
	endif
	enddo
	return
	end


C
C 5-11-99:  J. Smart  AFWA code modified for inclusion into LAPS satellite
C                     library to compute METEOSAT line/pixel values for
c                     given LAPS lat/lon.
C   4.4.1.2.2.11.7.1 FC01_CONV_PTS_EL_TO_MET_1
CA
C   FC01_CONV_PTS_EL_TO_MET_1 converts latitude/longitude in radians to
C   pixel scanline number using algorithm described in annex "E"
C   to the meteosat-5 calibration report (April 1991). prepared by the
C   meteosat exploitation project at european space operations center.
CE
C---------------------  ARGUMENTS PASSED  ---------------------------
CCA
C
C      NAME                    I/O        DESCRIPTION
C
C      LATITUDE                 I   INPUT LATITUDE
C
C      LONGITUDE                I   INPUT LONGITUDE
C
C      X_COORD                  O   OUTPUT X COORDINATE
C
C      Y_COORD                  O   OUTPUT Y COORDINATE
C
C      CSTATUS                  O   ERROR CODE C
CCAE
C-------------------  SOFTWARE UNIT HISTORY  ------------------------
CH
C
C       06DEC95 : created, SCR95124, sfl;
C       26FEB97 : renamed RS to RS1 to avoid conflict with Ingest
C                  include file, sdhsup3, kla;
C
C      25MAR97 : SDHSU   Placed key in comments for
C                        SDD Sec 4 generation; RFB
CHE

C--------------------------------------------------------------------
C
C     Procedure FC01_CONV_PTS_EL_TO_MET_1 is
C
CP    begin
CE    end FC01_CONV_PTS_EL_TO_MET_1 ;
C
C--------------------------------------------------------------------

      SUBROUTINE FC01_CONV_PTS_EL_TO_MET_1(golonsbp,
     &                          stop_pix,fsci,
     &                          start_line,decimat,
     &                          ct,
     &                          LATITUDE,
     &                          LONGITUDE,
     &                          X_COORD,
     &                          Y_COORD,
     &                          CSTATUS)

      IMPLICIT NONE

c     INCLUDE 'data_type_code_tables.inc'
c     INCLUDE 'message_data_variables.inc'
c     INCLUDE 'is1_ingest_parameters_5.inc'

      CHARACTER ct*(*)

      REAL   LATITUDE,
     &       LONGITUDE,
     &       X_COORD,
     &       Y_COORD

      INTEGER   CSTATUS

      REAL   H
      PARAMETER (H = 35785.845)
      REAL   RE
      PARAMETER (RE = 6378.155)
      REAL   A
      PARAMETER (A = 1.0/297.0)
      REAL   RP
      PARAMETER (RP = RE/(1.0+A))
      REAL   PI
      PARAMETER (PI = 3.141592653)
      REAL   CDR
      PARAMETER (CDR = PI/180.0)
      REAL   CRD
      PARAMETER (CRD = 180.0/PI)
      INTEGER   LPSI2
      PARAMETER (LPSI2 = 1)
      REAL   DELTAX
      PARAMETER (DELTAX = 18.0/2500.0)
      REAL   DELTAY
      PARAMETER (DELTAY = 18.0/2500.0)

      REAL   XFI,
     &       XLA,
     &       ROM,
     &       Y,
     &       R1,
     &       R2,
     &       RS1,
     &       XR,
     &       YR,
     &       XT,
     &       YT,
     &       ZT,
     &       PX,
     &       PY,
     &       TETA
      REAL   RADJUST
      Real      golonsbp
      Integer   start_line
      Integer   stop_pix
      Integer   fsci
      Integer   decimat

c     INCLUDE 'data_areas_imd_hdr_offsets.inc'
c     INCLUDE 'data_areas_imd_hdr_data_names.inc'

c     COMMON /BLOCK_13/ IMAGE_LIST_CHAR

C-----------------------------------------------------------
C--   BEGIN
C-----------------------------------------------------------
C#
      CSTATUS = 0
      RADJUST=1.0
      IF(CT.EQ.'vis')RADJUST=2.0
      XFI = LATITUDE * CDR
      XLA = (LONGITUDE - GOLONSBP) * CDR
      ROM = (RE * RP)/SQRT(RP**2 * COS(XFI)**2 + RE**2 * SIN(XFI)**2)
      Y = SQRT(H**2 + ROM**2 - 2 * H * ROM * COS(XFI) * COS(XLA))
      R1 = Y**2 + ROM**2
      R2 = H**2

      IF (R1 .GT. R2) THEN
         X_COORD = 9999.
         Y_COORD = 9999.
         CSTATUS = 1
      ELSE
         RS1 = RE + H
         TETA = ATAN((RP / RE) * TAN(XFI))
         XT = RE * COS(TETA) * COS(XLA)
         YT = RE * COS(TETA) * SIN(XLA)
         ZT = RP * SIN(TETA)

         PX = ATAN(YT / (XT-RS1))

         PY = ATAN(ZT * (-1.0 / (XT-RS1))
     &                * COS(PX))

         PX = PX * CRD
         PY = PY * CRD

         XR = PX / (DELTAX * LPSI2)
         YR = PY / (DELTAY * LPSI2)

         IF(XR .GE. 0.0) XR = INT(PX / (DELTAX * LPSI2)) + 0.5
         IF(XR .LT. 0.0) XR = INT(PX / (DELTAX * LPSI2)) - 0.5
         IF(YR .GE. 0.0) YR = INT(PY / (DELTAY * LPSI2)) + 0.5
         IF(YR .LT. 0.0) YR = INT(PY / (DELTAY * LPSI2)) - 0.5

         X_COORD = (XR + 1250.0)*radjust
         Y_COORD = (YR + 1251.0)*radjust
c
c compute file relative x/y coordinate positions.
c
         X_COORD = X_COORD/DECIMAT
         X_COORD = STOP_PIX-X_COORD

         Y_COORD = Y_COORD - FSCI
         Y_COORD = Y_COORD/DECIMAT + 0.5
         Y_COORD = Y_COORD - START_LINE

C        Y_COORD = ((Y_COORD-(FSCI/radjust))/DECIMAT)+0.5-START_LINE

      END IF

99999 RETURN
      END


module EOS_JWL
  implicit none

contains
subroutine compute_pref_eos_jwl(p_ref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: p_ref
  double precision :: v
  v = rho0/rho
  p_ref = a*exp(-r1*v) + b*exp(-r2*v)
end subroutine compute_pref_eos_jwl

subroutine compute_dpref_eos_jwl(dpref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: dpref
  double precision :: v
  v = rho0/rho
  dpref = a*exp(-r1*v)*r1*rho0/rho**2 &
         +b*exp(-r2*v)*r2*rho0/rho**2
end subroutine compute_dpref_eos_jwl

subroutine compute_dpref2_eos_jwl(dpref,pref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: dpref,pref
  double precision :: v,expr1v,expr2v
  v = rho0/rho
  expr1v = exp(-r1*v)
  expr2v = exp(-r2*v)
  pref   = a*expr1v + b*expr2v
  dpref  = a*expr1v*r1*rho0/rho**2 &
          +b*expr2v*r2*rho0/rho**2
end subroutine compute_dpref2_eos_jwl

subroutine compute_eiref_eos_jwl(ei_ref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: ei_ref
  double precision :: v
  v = rho0/rho
  ei_ref = a*exp(-r1*v)/(r1*rho0) &
          +b*exp(-r2*v)/(r2*rho0)
end subroutine compute_eiref_eos_jwl

subroutine compute_deiref_eos_jwl(deref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: deref
  double precision :: v
  v = rho0/rho
  deref = a*exp(-r1*v)/rho**2 &
         +b*exp(-r2*v)/rho**2
end subroutine compute_deiref_eos_jwl

subroutine compute_deiref2_eos_jwl(deref,eref,rho,a,b,r1,r2,rho0)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(in) :: a,b,r1,r2,rho0
  double precision,intent(inout) :: deref,eref
  double precision :: v,expr1v,expr2v
  v = rho0/rho
  expr1v = exp(-r1*v)
  expr2v = exp(-r2*v)
  eref   = a*expr1v/(r1*rho0) &
          +b*expr2v/(r2*rho0)
  deref  = a*expr1v/rho**2 &
          +b*expr2v/rho**2
end subroutine compute_deiref2_eos_jwl

subroutine compute_gamma_eos_jwl(gamma,rho,gamma0)
  implicit none
  double precision,intent(in) :: rho,gamma0
  double precision,intent(inout) :: gamma
  gamma = gamma0
end subroutine

subroutine compute_xi_eos_jwl(xi,rho,gamma0)
  implicit none
  double precision,intent(in) :: rho,gamma0
  double precision,intent(inout) :: xi
  double precision :: gamma
  call compute_gamma_eos_jwl(gamma,rho,gamma0)
  xi = 1.d0/gamma
end subroutine

! compute the internal energy of product
subroutine compute_ei_eos_jwl(ei,p,rho,a,b,r1,r2,rho0,gamma0,q0)
  implicit none
  double precision,intent(in) :: p,rho,a,b,r1,r2,rho0,gamma0,q0
  double precision,intent(inout) :: ei
  double precision :: p_ref, ei_ref,gamma
  call compute_pref_eos_jwl(p_ref,rho,a,b,r1,r2,rho0)
  call compute_eiref_eos_jwl(ei_ref,rho,a,b,r1,r2,rho0)
  call compute_gamma_eos_jwl(gamma,rho,gamma0)
  ei = (p - p_ref)/(rho*gamma) + ei_ref - q0
end subroutine compute_ei_eos_jwl

! compute de/drho
subroutine compute_dedr_eos_jwl(dedr,p,rho,a,b,r1,r2,rho0,gamma0)
  implicit none
  double precision,intent(in) :: p,rho,a,b,r1,r2,rho0,gamma0
  double precision,intent(inout) :: dedr
  double precision :: p_ref, gamma
  double precision :: expr1v,expr2v
  double precision :: dprefdr
  double precision :: derefdr
  double precision :: v
  v = rho0/rho
  call compute_gamma_eos_jwl(gamma,rho,gamma0)
  expr1v = exp(-r1*v)
  expr2v = exp(-r2*v)
  p_ref    = a*expr1v + b*expr2v
  dprefdr  = a*expr1v*r1*rho0/rho**2 &
            +b*expr2v*r2*rho0/rho**2
  derefdr = a*expr1v/rho**2 + b*expr2v/rho**2
  dedr    = (-dprefdr*gamma*rho-(p-p_ref)*gamma)/(rho*gamma)**2 + derefdr
end subroutine compute_dedr_eos_jwl

! compute de/dp
subroutine compute_dedp_eos_jwl(dedp,p,rho,gamma0)
  implicit none
  double precision,intent(in) :: p,rho,gamma0
  double precision,intent(inout) :: dedp
  double precision :: gamma
  call compute_gamma_eos_jwl(gamma,rho,gamma0)
  dedp = 1.0/(gamma*rho)
end subroutine compute_dedp_eos_jwl

! compute the sound speed
subroutine compute_sound_eos_jwl(c2,p,rho,a,b,r1,r2,rho0,gamma0)
  implicit none
  double precision,intent(in) :: p,rho,a,b,r1,r2,rho0,gamma0
  double precision,intent(inout) :: c2
  double precision :: dedp,dedr
  call compute_dedp_eos_jwl(dedp,p,rho,gamma0)
  call compute_dedr_eos_jwl(dedr,p,rho,a,b,r1,r2,rho0,gamma0)
  c2 = (p/rho**2-dedr)/dedp
end subroutine compute_sound_eos_jwl
end module


      double precision function randlc(x, a)

c---------------------------------------------------------------------
c
c   This routine returns a uniform pseudorandom double precision number in the
c   range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The returned value RANDLC is normalized to be
c   between 0 and 1, i.e. RANDLC = 2^(-46) * x_1.  X is updated to contain
c   the new seed x_1, so that subsequent calls to RANDLC using the same
c   arguments will generate a continuous sequence.

      implicit none
      double precision x, a
      integer*8 i246m1, Lx, La
      double precision d2m46
      save i246m1
c      data i246m1/X'00003FFFFFFFFFFF'/
      data i246m1/0/

      parameter(d2m46=0.5d0**46)

      if (i246m1.eq.0) i246m1='00003FFFFFFFFFFF'X
      Lx = X
      La = A

      Lx   = iand(Lx*La,i246m1)
      randlc = d2m46*dble(Lx)
      x    = dble(Lx)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      SUBROUTINE VRANLC (N, X, A, Y)
      implicit none
      integer n, i
      double precision x, a, y(*)
      integer*8 i246m1, Lx, La
      double precision d2m46

c This doesn't work, because the compiler does the calculation in 32
c bits and overflows. No standard way (without f90 stuff) to specify
c that the rhs should be done in 64 bit arithmetic.
c      parameter(i246m1=2**46-1)
      save i246m1
c      data i246m1/X'00003FFFFFFFFFFF'/
      data i246m1/0/

      parameter(d2m46=0.5d0**46)

c Note that the v6 compiler on an R8000 does something stupid with
c the above. Using the following instead (or various other things)
c makes the calculation run almost 10 times as fast.
c
c      save d2m46
c      data d2m46/0.0d0/
c      if (d2m46 .eq. 0.0d0) then
c         d2m46 = 0.5d0**46
c      endif

      if (i246m1.eq.0) i246m1='00003FFFFFFFFFFF'X

      Lx = X
      La = A
      do i = 1, N
         Lx   = iand(Lx*La,i246m1)
         y(i) = d2m46*dble(Lx)
      end do
      x    = dble(Lx)

      return
      end


      SUBROUTINE DCPOSE(NDIM,N,QR,ALPHA,PIVOT,IERR,Y,SUM)
C
C SUBROUTINE  DCPOSE  IS A MODIFICATION OF THE ALGOL PROCEDURE
C DECOMPOSE  IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST
C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS,
C NUMER. MATH. 7 (1965) 269-276.
C
      INTEGER NDIM,N,PIVOT(1)
      DOUBLE PRECISION QR(NDIM,1),ALPHA(N)
      INTEGER IERR,I,J,JBAR,K,KP1,NP1
      DOUBLE PRECISION BETA,SIGMA,ALPHAK,QRKK,Y(1),SUM(1)
      DOUBLE PRECISION DDOT
      IERR=0
      NP1=N+1
      DO 20 J=1,NP1
        SUM(J)=DDOT(N,QR(1,J),1,QR(1,J),1)
20    PIVOT(J)=J
      DO 500 K=1,N
        SIGMA=SUM(K)
        JBAR=K
        KP1=K+1
        DO 40 J=KP1,NP1
          IF (SIGMA .GE. SUM(J)) GO TO 40
          SIGMA=SUM(J)
          JBAR=J
40      CONTINUE
        IF (JBAR .EQ. K) GO TO 70
        I=PIVOT(K)
        PIVOT(K)=PIVOT(JBAR)
        PIVOT(JBAR)=I
        SUM(JBAR)=SUM(K)
        SUM(K)=SIGMA
        DO 50 I=1,N
          SIGMA=QR(I,K)
          QR(I,K)=QR(I,JBAR)
          QR(I,JBAR)=SIGMA
50      CONTINUE
C   END OF COLUMN INTERCHANGE.
70      SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1)
        IF (SIGMA .NE. 0.0) GO TO 60
        IERR=1
        RETURN
60      IF (K .EQ. N) GO TO 500
        QRKK=QR(K,K)
        ALPHAK=-SQRT(SIGMA)
        IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK
        ALPHA(K)=ALPHAK
        BETA=1.0/(SIGMA-QRKK*ALPHAK)
        QR(K,K)=QRKK-ALPHAK
        DO 80 J=KP1,NP1
80      Y(J)=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1)
        DO 100 J=KP1,NP1
          DO 90 I=K,N
            QR(I,J)=QR(I,J)-QR(I,K)*Y(J)
90        CONTINUE
          SUM(J)=SUM(J)-QR(K,J)**2
100     CONTINUE
500   CONTINUE
      ALPHA(N)=QR(N,N)
      RETURN
      END


      subroutine bchslv ( w, nbands, nrow, b )
c  from  * a practical guide to splines *  by c. de boor
c  solves the linear system	c*x = b   of order  n r o w  for  x
c  provided  w	contains the cholesky factorization for the banded (sym-
c  metric) positive definite matrix  c	as constructed in the subroutine
c    b c h f a c  (quo vide).
c
c******  i n p u t  ******
c  nrow.....is the order of the matrix	c .
c  nbands.....indicates the bandwidth of  c .
c  w.....contains the cholesky factorization for  c , as output from
c	 subroutine bchfac  (quo vide).
c  b.....the vector of length  n r o w	containing the right side.
c
c******  o u t p u t  ******
c  b.....the vector of length  n r o w	containing the solution.
c
c******  m e t h o d  ******
c  with the factorization  c = l*d*l-transpose	available, where  l  is
c  unit lower triangular and  d  is diagonal, the triangular system
c  l*y = b  is solved for  y (forward substitution), y is stored in  b,
c  the vector  d**(-1)*y is computed and stored in  b, then the triang-
c  ular system	l-transpose*x = d**(-1)*y is solved for  x (backsubstit-
c  ution).
      integer nbands,nrow,   j,jmax,n,nbndm1
      real w(nbands,nrow),b(nrow)
      if (nrow .gt. 1)			go to 21
      b(1) = b(1)*w(1,1)
					return
c
c		  forward substitution. solve l*y = b for y, store in b.
   21 nbndm1 = nbands - 1
      do 30 n=1,nrow
	 jmax = min0(nbndm1,nrow-n)
	 if (jmax .lt. 1)		go to 30
	 do 25 j=1,jmax
   25	    b(j+n) = b(j+n) - w(j+1,n)*b(n)
   30	 continue
c
c     backsubstitution. solve l-transp.x = d**(-1)*y  for x, store in b.
      n = nrow
   31	 b(n) = b(n)*w(1,n)
	 jmax = min0(nbndm1,nrow-n)
	 if (jmax .lt. 1)		go to 40
	 do 35 j=1,jmax
   35	    b(n) = b(n) - w(j+1,n)*b(j+n)
   40	 n = n-1
      if (n.gt.0)			go to 31
					return
      end


MODULE bb_module

  implicit none

  PRIVATE
  PUBLIC :: construct_bb
  PUBLIC :: calc_bb

  real(8),PUBLIC :: bb(3,3)

CONTAINS

  SUBROUTINE construct_bb(aa)
    implicit none
    real(8),intent(IN) :: aa(3,3)
    real(8) :: Vaa,PI2
    PI2 = 2.d0*acos(-1.d0)
    Vaa = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
         +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
         -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
    bb(1,1) = aa(2,2)*aa(3,3) - aa(3,2)*aa(2,3)
    bb(2,1) = aa(3,2)*aa(1,3) - aa(1,2)*aa(3,3)
    bb(3,1) = aa(1,2)*aa(2,3) - aa(2,2)*aa(1,3)
    bb(1,2) = aa(2,3)*aa(3,1) - aa(3,3)*aa(2,1)
    bb(2,2) = aa(3,3)*aa(1,1) - aa(1,3)*aa(3,1)
    bb(3,2) = aa(1,3)*aa(2,1) - aa(2,3)*aa(1,1)
    bb(1,3) = aa(2,1)*aa(3,2) - aa(3,1)*aa(2,2)
    bb(2,3) = aa(3,1)*aa(1,2) - aa(1,1)*aa(3,2)
    bb(3,3) = aa(1,1)*aa(2,2) - aa(2,1)*aa(1,2)
    bb(:,:)=bb(:,:)*PI2/Vaa
  END SUBROUTINE construct_bb

  SUBROUTINE calc_bb(aa,bb_out)
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: bb_out(3,3)
    real(8) :: Vaa,PI2
    PI2 = 2.d0*acos(-1.d0)
    Vaa = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
         +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
         -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
    bb_out(1,1) = aa(2,2)*aa(3,3) - aa(3,2)*aa(2,3)
    bb_out(2,1) = aa(3,2)*aa(1,3) - aa(1,2)*aa(3,3)
    bb_out(3,1) = aa(1,2)*aa(2,3) - aa(2,2)*aa(1,3)
    bb_out(1,2) = aa(2,3)*aa(3,1) - aa(3,3)*aa(2,1)
    bb_out(2,2) = aa(3,3)*aa(1,1) - aa(1,3)*aa(3,1)
    bb_out(3,2) = aa(1,3)*aa(2,1) - aa(2,3)*aa(1,1)
    bb_out(1,3) = aa(2,1)*aa(3,2) - aa(3,1)*aa(2,2)
    bb_out(2,3) = aa(3,1)*aa(1,2) - aa(1,1)*aa(3,2)
    bb_out(3,3) = aa(1,1)*aa(2,2) - aa(2,1)*aa(1,2)
    bb_out(:,:)=bb_out(:,:)*PI2/Vaa
  END SUBROUTINE calc_bb

END MODULE bb_module


!  This program finds the eigenvalues and eigenvectors for a random 20x20 real matrix.
!  The peculiar algorithm used is not a very good way to do this, but is a test for several
!  of the FM sample subroutines.

!  Some trace output is written to the screen as the program runs, and the eigenvalues and
!  eigenvectors are written to file EigenSystem.out at the end.

      MODULE EIGEN_VARIABLES
      USE FMZM

!  COEFFS holds the coefficients for the characteristic polynomial of a matrix.
!  N_COEFFS is the number of coefficients, and NDIG_OF_COEFFS is their precision.

      TYPE (FM), ALLOCATABLE :: COEFFS(:)
      INTEGER, SAVE :: N_COEFFS, NDIG_OF_COEFFS

      END MODULE EIGEN_VARIABLES

      PROGRAM TEST
      USE FMZM
      IMPLICIT NONE

      TYPE (FM), ALLOCATABLE :: A(:,:)
      TYPE (ZM), ALLOCATABLE :: EIGENVECTORS(:,:), EIGENVALUES(:)
      TYPE (FM) :: ERR
      INTEGER :: SEED(7)
      INTEGER :: J, K, KU, KPRT, N
      DOUBLE PRECISION :: XVAL
      REAL :: TIME1, TIME2

      N = 20
      K = 40
      KPRT = 1
      KU = 6
      CALL FM_SET(K)

      ALLOCATE(A(N,N),EIGENVECTORS(N,N),EIGENVALUES(N),STAT=J)
      IF (J /= 0) STOP
      CALL FM_SETVAR(" KSWIDE = 110 ")

!             Generate an NxN matrix of random integers between -100 and +100.

      CALL FM_RANDOM_SEED_SIZE(J)
      SEED(1:J) = 13
      SEED(1) = N
      SEED(2) = K
      CALL FM_RANDOM_SEED_PUT(SEED(1:J))
      DO J = 1, N
         DO K = 1, N
            CALL FM_RANDOM_NUMBER(XVAL)
            A(J,K) = INT(200*XVAL - 100)
         ENDDO
      ENDDO

!             Find the Eigenvalues and Eigenvectors.

      CALL CPU_TIME(TIME1)

      CALL FM_EIGENSYSTEM(A,N,EIGENVECTORS,EIGENVALUES,KPRT,KU)

      CALL CPU_TIME(TIME2)

!             Write the solution.

      OPEN(22,FILE='EigenSystem.out')
      CALL FM_SETVAR(" KW = 22 ")
      DO J = 1, N
         WRITE (22,*) ' '
         WRITE (22,"(A,I3,A)") ' Eigenvalue  ',J,':'
         CALL ZM_PRINT(EIGENVALUES(J))
         WRITE (22,*) ' '
         WRITE (22,"(A,I3,A)") ' Eigenvector ',J,':'
         DO K = 1, N
            CALL ZM_PRINT(EIGENVECTORS(K,J))
         ENDDO
      ENDDO
      WRITE (22,*) ' '
      WRITE (22,*) ' '

!             Find the norm of the residual,  A X - c X  for each eigenvalue c and eigenvector X.

      ERR = 0
      DO J = 1, N
         ERR = ERR + SUM(ABS(MATMUL(TO_ZM(A(1:N,1:N)),EIGENVECTORS(1:N,J)) -  &
                             EIGENVALUES(J)*EIGENVECTORS(1:N,J)))
      ENDDO
      WRITE (*,*) ' '
      WRITE (*,"(A,ES16.7)") ' Norm of the residual = ',TO_DP(ERR/N**2)
      WRITE (*,*) ' '

      WRITE (*,*) ' '
      WRITE (*,"(A,F9.2,A)") '  Time to solve the system: ',TIME2-TIME1,' seconds.'
      WRITE (*,*) ' '
      WRITE (*,*) ' The eigenvalues and eigenvectors are in file EigenSystem.out.'
      WRITE (*,*) ' '

      STOP

      END PROGRAM TEST

      SUBROUTINE FM_EIGENSYSTEM(A,N,EIGENVECTORS,EIGENVALUES,KPRT,KU)
      USE FMVALS
      USE FMZM
      USE EIGEN_VARIABLES
      IMPLICIT NONE

!  Find the eigensystem for real NxN matrix A.

!  EIGENVALUES(1:N) is returned with the (complex) eigenvalues.

!  EIGENVECTORS(1:N,J) is returned with the (complex) eigenvector corresponding to EIGENVALUES(J),
!                      for J = 1, 2, ..., N.

!  A is a type (fm) multiprecision real array,
!  EIGENVALUES and EIGENVECTORS are type (zm) multiprecision complex arrays.

!  KPRT  controls printing within the routine:
!        KPRT = 0 for no output
!        KPRT = 1 for some trace output.

!  KU    is the unit number for output.

!  This routine does not handle cases with eigenvalues of multiplicity greater than 1,  since
!  some of those cases do not have a full set of N eigenvectors.

!  The algorithm used here is not the best way to compute eigensystems.  It is not even a good
!  way to do it.  But it was easy to code using existing FM routines for finding determinants
!  and all the roots of a polynomial, and it has a certain Rube Goldberg charm.

!  Algorithm:   1.  Generate the N+1 matrices  A - lambda*I  for lambda = 1, 2, ..., N+1
!               2.  Use FM_FACTOR_LU to find the N+1 determinants for these matrices
!               3.  Use FM_LIN_SOLVE to find the N+1 coefficients of the Nth degree characteristic
!                   polynomial for A, using the points on the curve found in step 2.
!               4.  Use ZM_ROOTS to find the N (complex) roots of this polynomial.
!                   These roots are the eigenvalues.
!               5.  For each eigenvalue, do a few iterations of the inverse power method to find
!                   the corresponding eigenvector.

      INTEGER :: I, J, JMAX, K, KPRT, KU, KWARN_SAVE, LAMBDA, N, NDSAVE, N_FOUND
      TYPE (FM) :: A(N,N)
      TYPE (ZM) :: EIGENVALUES(N), EIGENVECTORS(N,N)
      TYPE (FM), SAVE :: DET, P, TOL
      TYPE (FM), ALLOCATABLE :: A1(:,:), A2(:,:), EQN(:,:), IDENTITY(:,:), RHS(:)
      TYPE (ZM), ALLOCATABLE :: Z1(:,:), Z2(:,:), ZX(:), ZT(:), LIST_OF_ROOTS(:)
      TYPE (ZM), SAVE :: T, ZDET
      INTEGER, ALLOCATABLE :: KSWAP(:)
      TYPE (ZM), EXTERNAL :: EIGEN_POLY

!             Raise precision slightly.

      NDSAVE = NDIG
      NDIG = NDIG + NGRD52
      KWARN_SAVE = KWARN
      KWARN = 0

      ALLOCATE(A1(N,N),A2(N,N),EQN(N+1,N+1),IDENTITY(N,N),Z1(N,N),Z2(N,N),ZX(N),ZT(N),RHS(N+1),  &
               COEFFS(N+1),LIST_OF_ROOTS(N),KSWAP(N),STAT=J)
      IF (J /= 0) THEN
          WRITE (KU,"(/' Error in FM_EIGENSYSTEM.  Unable to allocate arrays with N = ',I8/)") N
          STOP
      ENDIF

!             Copy A to A1 with higher precision, and generate an identity matrix.

  110 TOL = TO_FM(MBASE)**(-NDSAVE)
      IDENTITY = 0
      DO I = 1, N
         DO J = 1, N
            CALL FM_EQU(A(I,J),A1(I,J),NDSAVE,NDIG)
         ENDDO
         IDENTITY(I,I) = 1
      ENDDO

!             Generate the N+1 (real) N x N matrices  A - lambda*I  for lambda = 1, 2, ..., N+1,
!             and find the N+1 determinants for these matrices

      DO LAMBDA = 1, N+1
         A2 = A1 - LAMBDA*IDENTITY
         CALL FM_FACTOR_LU(A2,N,DET,KSWAP)
         P = 1
         DO J = N+1, 1, -1
            EQN(LAMBDA,J) = P
            P = LAMBDA*P
         ENDDO
         RHS(LAMBDA) = DET
      ENDDO
      N_COEFFS = N + 1

!             Find the (real) coefficients of the characteristic polynomial for A.

      CALL FM_LIN_SOLVE(EQN,COEFFS,RHS,N_COEFFS,DET)
      NDIG_OF_COEFFS = NDIG
      IF (DET == 0) THEN
          WRITE (KU,"(/' Error in FM_EIGENSYSTEM.  Zero determinant -- no unique ',"//  &
                    "'characteristic polynomial.'/)")
          STOP
      ENDIF

!             Use ZM_ROOTS to find all the (complex) roots of this polynomial.
!             These roots (in LIST_OF_ROOTS) are the eigenvalues.

      CALL ZM_ROOTS(N,EIGEN_POLY,1,N_FOUND,LIST_OF_ROOTS,KPRT,KU)

      IF (N_FOUND /= N) THEN
          IF (KPRT > 0) THEN
              WRITE (KU,"(/' In FM_EIGENSYSTEM, N_FOUND /= N.  N = ',"//  &
                        "I3,'.  N_FOUND =',I3/)") N,N_FOUND
              WRITE (KU,"(/' Increase precision and try again.'/)")
          ENDIF
          NDIG = 2*NDIG
          GO TO 110
      ENDIF

!             Sort the eigenvalues so they have decreasing magnitude, and check that there were
!             no multiple roots.

      DO I = 2, N
         JMAX = I-1
         DO J = I, N
            IF (ABS(LIST_OF_ROOTS(J)) > ABS(LIST_OF_ROOTS(JMAX))) JMAX = J
         ENDDO
         T = LIST_OF_ROOTS(I-1)
         LIST_OF_ROOTS(I-1) = LIST_OF_ROOTS(JMAX)
         LIST_OF_ROOTS(JMAX) = T
      ENDDO
      DO I = 2, N
         IF (LIST_OF_ROOTS(I-1) == LIST_OF_ROOTS(I)) THEN
             WRITE (KU,"(/' Error in FM_EIGENSYSTEM.  eigenvalues of multiplicity more than 1'/)")
             CALL ZM_PRINT(LIST_OF_ROOTS(I))
             STOP
         ENDIF
      ENDDO

!             For each eigenvalue, do a few iterations of the inverse power method to find
!             the corresponding eigenvector.
!             Since the A matrix is real, conjugate eigenvalues have conjugate eigenvectors,
!             so some eigenvectors may not need the inverse power method.

      DO I = 1, N
         IF (I > 1) THEN
             IF (LIST_OF_ROOTS(I) == CONJG(LIST_OF_ROOTS(I-1))) THEN
                 DO K = 1, N
                    CALL ZM_EQU(EIGENVECTORS(K,I-1),T,NDSAVE,NDIG)
                    CALL ZM_EQU(CONJG(T),EIGENVECTORS(K,I),NDIG,NDSAVE)
                 ENDDO
                 CALL ZM_EQU(EIGENVALUES(I-1),T,NDSAVE,NDIG)
                 CALL ZM_EQU(CONJG(T),EIGENVALUES(I),NDIG,NDSAVE)
                 CYCLE
             ENDIF
         ENDIF
         P = (1 + EPSILON(TO_FM(1))**0.3D0)
         Z1 = A1
         DO J = 1, N
            Z1(J,J) = Z1(J,J) - P*LIST_OF_ROOTS(I)
         ENDDO
         CALL ZM_INVERSE(Z1,N,Z2,ZDET)
         ZX = 1
         DO J = 1, 6
            ZX = MATMUL(Z2,ZX)
            ZX = ZX / SQRT(ABS(DOT_PRODUCT(ZX,ZX)))
            ZT = MATMUL(TO_ZM(A1),ZX) - LIST_OF_ROOTS(I)*ZX
            P = SQRT(ABS(DOT_PRODUCT(ZT,ZT)))
            IF (P < TOL) THEN
                DO K = 1, N
                   CALL ZM_EQU(ZX(K),EIGENVECTORS(K,I),NDIG,NDSAVE)
                ENDDO
                CALL ZM_EQU(LIST_OF_ROOTS(I),EIGENVALUES(I),NDIG,NDSAVE)
                EXIT
            ENDIF
            IF (J == 6) THEN
                IF (KPRT > 0) THEN
                    WRITE (KU,                                                                     &
                          "(/' In FM_EIGENSYSTEM inverse iteration did not converge for I = ',"//  &
                          "I3,'.'/' Error =',ES15.7,' was not less than Tol =',ES15.7)") I,        &
                          TO_DP(P),TO_DP(TOL)
                    WRITE (KU,"(/' Increase precision and try again.'/)")
                ENDIF
                NDIG = 2*NDIG
                GO TO 110
            ENDIF
         ENDDO
      ENDDO

      DEALLOCATE(A1,A2,EQN,IDENTITY,Z1,Z2,ZX,ZT,RHS,COEFFS,LIST_OF_ROOTS,KSWAP)

      NDIG = NDSAVE
      KWARN = KWARN_SAVE
      END SUBROUTINE FM_EIGENSYSTEM

      FUNCTION EIGEN_POLY(X,NF)     RESULT (RETURN_VALUE)
      USE EIGEN_VARIABLES
      USE FMVALS
      USE FMZM
      IMPLICIT NONE

!  X  is the argument to the function.
!  NF is the function number.

      INTEGER :: J, NF
      TYPE (ZM) :: RETURN_VALUE, X
      TYPE (FM), SAVE :: D

      IF (NF == 1) THEN
          CALL FM_EQU(COEFFS(1),D,NDIG_OF_COEFFS,NDIG)
          RETURN_VALUE = D
          DO J = 2, N_COEFFS
             CALL FM_EQU(COEFFS(J),D,NDIG_OF_COEFFS,NDIG)
             RETURN_VALUE = RETURN_VALUE*X + D
          ENDDO
      ELSE
          RETURN_VALUE = 3*X - 2
      ENDIF

      END FUNCTION EIGEN_POLY