c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file divgs.f
c
c     this file includes documentation and code for
c     subroutine divgs          i
c
c ... files which must be loaded with divgs.f
c
c     sphcom.f, hrfft.f, vhags.f, shsgs.f, gaqd.f
c
c
c     subroutine divgs(nlat,nlon,isym,nt,divg,idiv,jdiv,br,bi,mdb,ndb,
c    +                 wshsgs,lshsgs,work,lwork,ierror)
c
C*PL*ERROR* Comment line too long
c     given the vector spherical harmonic coefficients br and bi, precomputed
c     by subroutine vhags for a vector field (v,w), subroutine divgs
C*PL*ERROR* Comment line too long
c     computes the divergence of the vector field in the scalar array divg.
C*PL*ERROR* Comment line too long
c     divg(i,j) is the divergence at the gaussian colatitude point theta(i)
c     (see nlat as input parameter) and east longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere.  i.e.
c
C*PL*ERROR* Comment line too long
c            dv(i,j) = 1/sint*[ d(sint*v(i,j))/dtheta + d(w(i,j))/dlambda ]
c
c     where sint = sin(theta(i)).  w is the east longitudinal and v
c     is the colatitudinal component of the vector field from which
c     br,bi were precomputed
c
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the divergence is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case the
c            divergence is neither symmetric nor antisymmetric about
c            the equator.  the divergence is computed on the entire
c            sphere.  i.e., in the array divg(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case the divergence is antisymmetyric about
c            the equator and is computed for the northern hemisphere
c            only.  i.e., if nlat is odd the divergence is computed
c            in the array divg(i,j) for i=1,...,(nlat+1)/2 and for
c            j=1,...,nlon.  if nlat is even the divergence is computed
c            in the array divg(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c      = 2
c            w is symmetric and v is antisymmetric about the equator
c            in this case the divergence is symmetyric about the
c            equator and is computed for the northern hemisphere
c            only.  i.e., if nlat is odd the divergence is computed
c            in the array divg(i,j) for i=1,...,(nlat+1)/2 and for
c            j=1,...,nlon.  if nlat is even the divergence is computed
c            in the array divg(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
c            in the program that calls divgs, the arrays br,bi, and divg
C*PL*ERROR* Comment line too long
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple scalar synthesis will
c            be performed to compute the divergence for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
C*PL*ERROR* Comment line too long
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     idiv   the first dimension of the array divg as it appears in
c            the program that calls divgs. if isym = 0 then idiv
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idiv must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idiv must be at least (nlat+1)/2.
c
c     jdiv   the second dimension of the array divg as it appears in
c            the program that calls divgs. jdiv must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhags.
c     ***    br and bi must be computed by vhags prior to calling
c            divgs.
c
c     mdb    the first dimension of the arrays br and bi as it
c            appears in the program that calls divgs. mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays br and bi as it
c            appears in the program that calls divgs. ndb must be at
c            least nlat.
c
c
c     wshsgs an array which must be intialized by subroutine shsgsi.
c            once initialized,
c            wshsgs can be used repeatedly by divgs as long as nlon
c            and nlat remain unchanged.  wshsgs must not be altered
c            between calls of divgs.
c
c
c     lshsgs the dimension of the array wshsgs as it appears in the
c            program that calls divgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgs must be at least
c
C*PL*ERROR* Comment line too long
c               nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls divgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c
c            if isym = 0 then lwork must be at least
c
c               nlat*((nt+1)*nlon+2*nt*l1+1)
c
c            if isym > 0 then lwork must be at least
c
c               (nt+1)*l2*nlon+nlat*(2*nt*l1+1)
c
c     **************************************************************
c
c     output parameters
c
c
c    divg   a two or three dimensional array (see input parameter nt)
c           that contains the divergence of the vector field (v,w)
c           whose coefficients br,bi where computed by subroutine
C*PL*ERROR* Comment line too long
c           vhags.  divg(i,j) is the divergence at the gaussian colatitude
C*PL*ERROR* Comment line too long
c           point theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon.
c           the index ranges are defined above at the input parameter
c           isym.
c
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idiv
c           = 6  error in the specification of jdiv
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshsgs
c           = 10 error in the specification of lwork
c **********************************************************************
c
c
      SUBROUTINE DDIVGS(NLAT,NLON,ISYM,NT,DIVG,IDIV,JDIV,BR,BI,MDB,NDB,
     +                  WSHSGS,LSHSGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION DIVG
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION WSHSGS
      DOUBLE PRECISION WORK

      DIMENSION DIVG(IDIV,JDIV,NT),BR(MDB,NDB,NT),BI(MDB,NDB,NT)
      DIMENSION WSHSGS(LSHSGS),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDIV.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IDIV.LT.IMID)) RETURN
      IERROR = 6
      IF (JDIV.LT.NLON) RETURN
      IERROR = 7
      IF (MDB.LT.MIN0(NLAT, (NLON+1)/2)) RETURN
      MMAX = MIN0(NLAT, (NLON+2)/2)
      IERROR = 8
      IF (NDB.LT.NLAT) RETURN
      IERROR = 9
      IMID = (NLAT+1)/2
      LPIMN = (IMID*MMAX* (NLAT+NLAT-MMAX+1))/2
c     check permanent work space length
      L2 = (NLAT+1)/2
      L1 = MIN0((NLON+2)/2,NLAT)
      LP = NLAT* (3* (L1+L2)-2) + (L1-1)* (L2* (2*NLAT-L1)-3*L1)/2 +
     +     NLON + 15
      IF (LSHSGS.LT.LP) RETURN
      IERROR = 10
c
c     verify unsaved work space (add to what shses requires, file f3)
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
c
c     set first dimension for a,b (as requried by shses)
c
      MAB = MIN0(NLAT,NLON/2+1)
      MN = MAB*NLAT*NT
      IF (LWORK.LT.NLN+LS*NLON+2*MN+NLAT) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IS = IB + MN
      IWK = IS + NLAT
      LWK = LWORK - 2*MN - NLAT
      CALL DDIVGS1(NLAT,NLON,ISYM,NT,DIVG,IDIV,JDIV,BR,BI,MDB,NDB,
     +            WORK(IA),WORK(IB),MAB,WORK(IS),WSHSGS,LSHSGS,
     +            WORK(IWK),LWK,IERROR)
      RETURN
      END

      SUBROUTINE DDIVGS1(NLAT,NLON,ISYM,NT,DIVG,IDIV,JDIV,BR,BI,MDB,NDB,
     +                  A,B,MAB,SQNN,WSHSGS,LSHSGS,WK,LWK,IERROR)
      DOUBLE PRECISION DIVG
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION WSHSGS
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION DIVG(IDIV,JDIV,NT),BR(MDB,NDB,NT),BI(MDB,NDB,NT)
      DIMENSION A(MAB,NLAT,NT),B(MAB,NLAT,NT),SQNN(NLAT)
      DIMENSION WSHSGS(LSHSGS),WK(LWK)
c
c     set coefficient multiplyers
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     compute divergence scalar coefficients for each vector field
c
      DO 2 K = 1,NT
          DO 3 N = 1,NLAT
              DO 4 M = 1,MAB
                  A(M,N,K) = 0.0D0
                  B(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              A(1,N,K) = -SQNN(N)*BR(1,N,K)
              B(1,N,K) = -SQNN(N)*BI(1,N,K)
    5     CONTINUE
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
          MMAX = MIN0(NLAT, (NLON+1)/2)
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  A(M,N,K) = -SQNN(N)*BR(M,N,K)
                  B(M,N,K) = -SQNN(N)*BI(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     synthesize a,b into divg
c
      CALL DSHSGS(NLAT,NLON,ISYM,NT,DIVG,IDIV,JDIV,A,B,MAB,NLAT,WSHSGS,
     +           LSHSGS,WK,LWK,IERROR)
      RETURN
      END


      SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To balance the matrices of the system pencil
C
C             S =  ( A  B ) - lambda ( E  0 ) :=  Q - lambda Z,
C                  ( C  0 )          ( 0  0 )
C
C     corresponding to the descriptor triple (A-lambda E,B,C),
C     by balancing. This involves diagonal similarity transformations
C     (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system
C     (A-lambda E,B,C) to make the rows and columns of system pencil
C     matrices
C
C                  diag(Dl,I) * S * diag(Dr,I)
C
C     as close in norm as possible. Balancing may reduce the 1-norms
C     of the matrices of the system pencil S.
C
C     The balancing can be performed optionally on the following
C     particular system pencils
C
C              S = A-lambda E,
C
C              S = ( A-lambda E  B ),    or
C
C              S = ( A-lambda E ).
C                  (     C      )
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates which matrices are involved in balancing, as
C             follows:
C             = 'A':  All matrices are involved in balancing;
C             = 'B':  B, A and E matrices are involved in balancing;
C             = 'C':  C, A and E matrices are involved in balancing;
C             = 'N':  B and C matrices are not involved in balancing.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     THRESH  (input) DOUBLE PRECISION
C             Threshold value for magnitude of elements:
C             elements with magnitude less than or equal to
C             THRESH are ignored for balancing. THRESH >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the balanced matrix Dl*A*Dr.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the balanced matrix Dl*E*Dr.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, if M > 0, the leading L-by-M part of this array
C             contains the balanced matrix Dl*B.
C             The array B is not referenced if M = 0.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, if P > 0, the leading P-by-N part of this array
C             contains the balanced matrix C*Dr.
C             The array C is not referenced if P = 0.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     LSCALE  (output) DOUBLE PRECISION array, dimension (L)
C             The scaling factors applied to S from left.  If Dl(j) is
C             the scaling factor applied to row j, then
C             SCALE(j) = Dl(j), for j = 1,...,L.
C
C     RSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             The scaling factors applied to S from right.  If Dr(j) is
C             the scaling factor applied to column j, then
C             SCALE(j) = Dr(j), for j = 1,...,N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*(L+N))
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     Balancing consists of applying a diagonal similarity
C     transformation
C                            -1
C                  diag(Dl,I)  * S * diag(Dr,I)
C
C     to make the 1-norms of each row of the first L rows of S and its
C     corresponding N columns nearly equal.
C
C     Information about the diagonal matrices Dl and Dr are returned in
C     the vectors LSCALE and RSCALE, respectively.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     [2] R.C. Ward, R. C.
C         Balancing the generalized eigenvalue problem.
C         SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the LAPACK routine DGGBAL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     May 2003, March 2004, Jan. 2009, May 2012.
C
C     KEYWORDS
C
C     Balancing, eigenvalue, matrix algebra, matrix operations,
C     similarity transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   HALF, ONE, ZERO
      PARAMETER          ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
      DOUBLE PRECISION   SCLFAC, THREE
      PARAMETER          ( SCLFAC = 1.0D+1, THREE = 3.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, L, LDA, LDB, LDC, LDE, M, N, P
      DOUBLE PRECISION   THRESH
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ), E( LDE, * ), LSCALE( * ),
     $                   RSCALE( * )
C     .. Local Scalars ..
      LOGICAL            WITHB, WITHC
      INTEGER            I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2,
     $                   KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN,
     $                   NRP2
      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, EPS, EW, EWC, GAMMA, PGAMMA, RAB,
     $                   SFMAX, SFMIN, SUM, T, TA, TB, TC, TE
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           DDOT, DLAMCH, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
C
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO  = 0
      WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' )
      WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' )
C
      IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) )
     $   THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( THRESH.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         DUM( 1 ) = ONE
         IF( L.GT.0 ) THEN
            CALL DCOPY( L, DUM, 0, LSCALE, 1 )
         ELSE IF( N.GT.0 ) THEN
            CALL DCOPY( N, DUM, 0, RSCALE, 1 )
         END IF
         RETURN
      END IF
C
C     Initialize balancing and allocate work storage.
C
      KW1 = N
      KW2 = KW1 + L
      KW3 = KW2 + L
      KW4 = KW3 + N
      KW5 = KW4 + L
      DUM( 1 ) = ZERO
      CALL DCOPY( L, DUM, 0, LSCALE, 1 )
      CALL DCOPY( N, DUM, 0, RSCALE, 1 )
      CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 )
C
C     Compute right side vector in resulting linear equations.
C
      BASL = LOG10( SCLFAC )
      DO 20 I = 1, L
         DO 10 J = 1, N
            TE = ABS( E( I, J ) )
            TA = ABS( A( I, J ) )
            IF( TA.GT.THRESH ) THEN
               TA = LOG10( TA ) / BASL
            ELSE
               TA = ZERO
            END IF
            IF( TE.GT.THRESH ) THEN
               TE = LOG10( TE ) / BASL
            ELSE
               TE = ZERO
            END IF
            DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE
            DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE
  10     CONTINUE
  20  CONTINUE
C
      IF( M.EQ.0 ) THEN
         WITHB = .FALSE.
         TB    = ZERO
      END IF
      IF( P.EQ.0 ) THEN
         WITHC = .FALSE.
         TC    = ZERO
      END IF
C
      IF( WITHB ) THEN
         DO 30 I = 1, L
            J = IDAMAX( M, B( I, 1 ), LDB )
            TB = ABS( B( I, J ) )
            IF( TB.GT.THRESH ) THEN
               TB = LOG10( TB ) / BASL
               DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB
            END IF
  30     CONTINUE
      END IF
C
      IF( WITHC ) THEN
         DO 40 J = 1, N
            I = IDAMAX( P, C( 1, J ), 1 )
            TC = ABS( C( I, J ) )
            IF( TC.GT.THRESH ) THEN
               TC = LOG10( TC ) / BASL
               DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC
            END IF
  40     CONTINUE
      END IF
C
      COEF  = ONE / DBLE( L+N )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2 = MAX( L, N ) + 2
      BETA = ZERO
      EPS  = DLAMCH( 'Precision' )
      IT = 1
C
C     Start generalized conjugate gradient iteration.
C
  50  CONTINUE
C
      GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) +
     $        DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 )
C
      EW = ZERO
      DO 60 I = 1, L
         EW = EW + DWORK( I+KW4 )
  60  CONTINUE
C
      EWC = ZERO
      DO 70 I = 1, N
         EWC = EWC + DWORK( I+KW5 )
  70  CONTINUE
C
      GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) -
     $                     COEF5*( EW - EWC )**2
      IF( ABS( GAMMA ).LE.EPS )
     $   GO TO 160
      IF( IT.NE.1 )
     $   BETA = GAMMA / PGAMMA
      T  = COEF5*( EWC - THREE*EW  )
      TC = COEF5*( EW  - THREE*EWC )
C
      CALL DSCAL( N+L, BETA, DWORK, 1 )
C
      CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 )
      CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 )
C
      DO 80 J = 1, N
         DWORK( J ) = DWORK( J ) + TC
   80 CONTINUE
C
      DO 90 I = 1, L
         DWORK( I+KW1 ) = DWORK( I+KW1 ) + T
   90 CONTINUE
C
C     Apply matrix to vector.
C
      DO 110 I = 1, L
         KOUNT = 0
         SUM = ZERO
         DO 100 J = 1, N
            IF( ABS( A( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( J )
            END IF
            IF( ABS( E( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( J )
            END IF
  100    CONTINUE
         IF( WITHB ) THEN
            J = IDAMAX( M, B( I, 1 ), LDB )
            IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1
         END IF
         DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM
  110 CONTINUE
C
      DO 130 J = 1, N
         KOUNT = 0
         SUM = ZERO
         DO 120 I = 1, L
            IF( ABS( A( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( I+KW1 )
            END IF
            IF( ABS( E( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( I+KW1 )
            END IF
  120    CONTINUE
         IF( WITHC ) THEN
            I = IDAMAX( P, C( 1, J ), 1 )
            IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1
         END IF
         DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM
  130 CONTINUE
C
      SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) +
     $      DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 )
      ALPHA = GAMMA / SUM
C
C     Determine correction to current iteration.
C
      CMAX = ZERO
      DO 140 I = 1, L
         COR = ALPHA*DWORK( I+KW1 )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         LSCALE( I ) = LSCALE( I ) + COR
  140 CONTINUE
C
      DO 150 J = 1, N
         COR = ALPHA*DWORK( J )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         RSCALE( J ) = RSCALE( J ) + COR
  150 CONTINUE
      IF( CMAX.LT.HALF )
     $   GO TO 160
C
      CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 )
      CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 )
C
      PGAMMA = GAMMA
      IT = IT + 1
      IF( IT.LE.NRP2 )
     $   GO TO 50
C
C     End generalized conjugate gradient iteration.
C
  160 CONTINUE
      SFMIN = DLAMCH( 'Safe minimum' )
      SFMAX = ONE / SFMIN
      LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
C
C     Compute left diagonal scaling matrix.
C
      DO 170 I = 1, L
         IRAB = IDAMAX( N, A( I, 1 ), LDA )
         RAB  = ABS( A( I, IRAB ) )
         IRAB = IDAMAX( N, E( I, 1 ), LDE )
         RAB  = MAX( RAB, ABS( E( I, IRAB ) ) )
         IF( WITHB ) THEN
            IRAB = IDAMAX( M, B( I, 1 ), LDB )
            RAB  = MAX( RAB, ABS( B( I, IRAB ) ) )
         END IF
         LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE )
         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
         LSCALE( I ) = SCLFAC**IR
  170 CONTINUE
C
C     Compute right diagonal scaling matrix.
C
      DO 180 J = 1, N
         ICAB = IDAMAX( L, A( 1, J ), 1 )
         CAB  = ABS( A( ICAB, J ) )
         ICAB = IDAMAX( L, E( 1, J ), 1 )
         CAB  = MAX( CAB, ABS( E( ICAB, J ) ) )
         IF( WITHC ) THEN
            ICAB = IDAMAX( P, C( 1, J ), 1 )
            CAB  = MAX( CAB, ABS( C( ICAB, J ) ) )
         END IF
         LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE )
         JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) )
         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
         RSCALE( J ) = SCLFAC**JC
  180 CONTINUE
C
C     Row scaling of matrices A, E and B.
C
      DO 190 I = 1, L
         CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA )
         CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE )
         IF( WITHB )
     $      CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB )
  190 CONTINUE
C
C     Column scaling of matrices A, E and C.
C
      DO 200 J = 1, N
         CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 )
         CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 )
         IF( WITHC )
     $      CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 )
  200 CONTINUE
C
      RETURN
C *** Last line of TG01AD ***
      END


!----------------------------------------------------------------------*
!  SUBROUTINE SUBDD                                                    *
!  Purpose: This subroutine calculates the daily amount of heat units  *
!           for calculation of the phenological development rate and   *
!           early leaf area growth.                                    *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! TMAX    R4  Daily maximum temperature (oC)                        I  *
! TMIN    R4  Daily minimum temperature (oC)                        I  *
! TBD     R4  Base temperature for development (oC)                 I  *
! TOD     R4  Optimum temperature for development (oC)              I  *
! TMD     R4  Maximum temperature for development (oC)              I  *
! HU      R4  Heat units (oCd d-1)                                  O  *
!                                                                      *
!  FILE usage : none                                                   *
!----------------------------------------------------------------------*
      SUBROUTINE SUBDD(TMAX,TMIN,TBD,TOD,TMD,HU)

      IMPLICIT NONE
!-----Formal parameters
      REAL    TMAX,TMIN,TBD,TOD,TMD,HU
!-----Local parameters
      REAL    TD, TM, TT, X1, X2
      INTEGER I
      SAVE         ! TAOLI

      TM = (TMAX+TMIN)/2.
      TT = 0.
	  X1= (TOD-TBD)/(TMD-TOD)		!TAOLI, APRIL 1,2009
	  X2=0.0						!TAOLI, APRIL 1,2009
      DO I = 1,24
         TD = TM+0.5*ABS(TMAX-TMIN)*COS(0.2618*FLOAT(I-14))

         IF ((TD.GT.TBD).AND.(TD.LT.TMD)) THEN

            IF (TD.GT.TOD) TD = TOD-(TD-TOD)*(TOD-TBD)/(TMD-TOD) !TAOLI, APRIL 1,2009, COMMENT OUT
            TT = TT+(TD-TBD)/24.
         END IF

      END DO
      HU = TT

      RETURN
      END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   Demo LCNF: The limit cycle BP normal form
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

 SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(OUT) :: F(NDIM), DFDU(NDIM,*), DFDP(NDIM,*)

   DOUBLE PRECISION pi

   pi=4*ATAN(1.d0)

! Equations
   F(1)=-U(1)*(U(1)**2+U(2)**2-(PAR(1)+PAR(2))*               &
        SQRT(U(1)**2+U(2)**2)+PAR(1)*PAR(2)+PAR(3))-2*pi*U(2)
   F(2)=-U(2)*(U(1)**2+U(2)**2-(PAR(1)+PAR(2))*               &
        SQRT(U(1)**2+U(2)**2)+PAR(1)*PAR(2)+PAR(3))+2*pi*U(1)

   IF(IJAC.EQ.0)RETURN

   DFDU(1,1)=-(U(1)**2+U(2)**2-(PAR(1)+PAR(2))*               &
        SQRT(U(1)**2+U(2)**2)+PAR(1)*PAR(2)+PAR(3))-U(1)*     &
        (2*U(1)-U(1)*(PAR(1)+PAR(2))/SQRT(U(1)**2+U(2)**2))
   DFDU(1,2)=-U(1)*(2*U(2)-U(2)*(PAR(1)+PAR(2))/              &
        SQRT(U(1)**2+U(2)**2))-2*pi
   DFDU(2,1)=-U(2)*(2*U(1)-U(1)*(PAR(1)+PAR(2))/              &
        SQRT(U(1)**2+U(2)**2))+2*pi
   DFDU(2,2)=-(U(1)**2+U(2)**2-(PAR(1)+PAR(2))*               &
        SQRT(U(1)**2+U(2)**2)+PAR(1)*PAR(2)+PAR(3))-U(2)*     &
        (2*U(2)-U(2)*(PAR(1)+PAR(2))/SQRT(U(1)**2+U(2)**2))

   IF(IJAC.EQ.1)RETURN

   DFDP(1,1)=-U(1)*(-SQRT(U(1)**2+U(2)**2)+PAR(2))
   DFDP(1,2)=-U(1)*(-SQRT(U(1)**2+U(2)**2)+PAR(1))
   DFDP(1,3)=-U(1)
   DFDP(2,1)=-U(2)*(-SQRT(U(1)**2+U(2)**2)+PAR(2))
   DFDP(2,2)=-U(2)*(-SQRT(U(1)**2+U(2)**2)+PAR(1))
   DFDP(2,3)=-U(2)

 END SUBROUTINE FUNC

 SUBROUTINE STPNT(NDIM,U,PAR,T)
!---------- -----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(IN) :: T
   DOUBLE PRECISION, INTENT(OUT) :: U(NDIM), PAR(*)

   DOUBLE PRECISION pi

   pi=4*ATAN(1.d0)

!  Parameters initialization
   PAR(1:3)=(/1.0,2.0,0.0/)
   PAR(11)=1.0

   U(1)=PAR(1)*COS(2*pi*T)
   U(2)=PAR(1)*SIN(2*pi*T)

 END SUBROUTINE STPNT

 SUBROUTINE BCND
 END SUBROUTINE BCND

 SUBROUTINE ICND
 END SUBROUTINE ICND

 SUBROUTINE FOPT
 END SUBROUTINE FOPT

 SUBROUTINE PVLS
 END SUBROUTINE PVLS


FUNCTION probks(alam)
REAL*8 probks,alam,EPS1,EPS2
PARAMETER (EPS1=0.001, EPS2=1.e-8)
INTEGER*4 j
REAL*8 a2,fac,term,termbf
a2=-2.*alam**2
fac=2.
probks=0.
termbf=0.
do j=1,100
	term=fac*exp(a2*j**2)
	probks=probks+term
	if(abs(term).le.EPS1*termbf.or.abs(term).le.EPS2*probks)return
	fac=-fac
	termbf=abs(term)
end do
probks=1.
return
END


PROGRAM Pascals_Triangle

  CALL Print_Triangle(8)

END PROGRAM Pascals_Triangle

SUBROUTINE Print_Triangle(n)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: n
  INTEGER :: c, i, j, k, spaces

  DO i = 0, n-1
     c = 1
     spaces = 3 * (n - 1 - i)
     DO j = 1, spaces
        WRITE(*,"(A)", ADVANCE="NO") " "
     END DO
     DO k = 0, i
        WRITE(*,"(I6)", ADVANCE="NO") c
        c = c * (i - k) / (k + 1)
     END DO
     WRITE(*,*)
  END DO

END SUBROUTINE Print_Triangle


!>
module m_schrodinger

  use m_parameters , only : TOLERANCE, MAX_ITERATIONS, SMALL, INFINITY
  use m_diffeq , only : numerov_f, numerov_b
  use m_integrate , only : integrate_trapezoid

  ! debugging
  use m_io

  implicit none

  ! private
  ! public :: shooting_bisection, numerov_cooley

contains

  ! harmonic_oscillator
  ! Brief:
  !
  ! Input:
  !
  ! Output:
  !
  subroutine harmonic_oscillator (n_x, step_size, omega, n_wf, &
      wf, energies, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: omega
    integer , intent(in) :: n_wf
    double precision , intent(out) :: wf(n_x, n_wf)
    double precision , intent(out) :: energies(n_wf)
    integer , intent(out) :: status
    double precision :: x_grid(n_x)
    double precision :: v_grid(n_x)
    integer :: ii, nn, iterations

    ! debug
    write (*, *) repeat('=', 80)
    write (*, *) "harmonic_oscillator()"

    ! initialise x_grid
    do ii = 1, n_x
      x_grid(ii) = step_size*(dble(ii) - dble(n_x + 1)/2.0d0)
    end do

    ! initialise v_grid
    do ii = 1, n_x
      v_grid(ii) = 0.5d0*(omega ** 2)*(x_grid(ii) ** 2)
    end do

    do nn = 1, n_wf
      ! call shooting_bisection(n_x, step_size, x_grid, omega, v_grid, nn-1, &
      !     wf(:, nn), energies(nn), iterations, status)
      call numerov_cooley(n_x, step_size, x_grid, omega, v_grid, nn-1, &
          wf(:, nn), energies(nn), iterations, status)

      ! terminate subroutine if numerov_cooley failed
      if (status /= 0) then
        wf(:, nn:n_wf) = 0.0d0
        energies(nn:n_wf) = 0.0d0
        write (*, *) "shooting_bisection() failed"
        write (*, *) "exiting harmonic_oscillator()"
        return
      end if
    end do

    ! debug
    write (*, *) "end harmonic_oscillator()"
    write (*, *) repeat('=', 80)

  end subroutine harmonic_oscillator

  ! shooting_bisection
  subroutine shooting_bisection (n_x, step_size, x_grid, omega, v_grid, n, &
      psi_grid, energy, iterations, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: x_grid(n_x)
    double precision , intent(in) :: omega
    double precision , intent(in) :: v_grid(n_x)
    integer , intent(in) :: n
    double precision , intent(out) :: psi_grid(n_x)
    double precision , intent(out) :: energy
    integer , intent(out) :: iterations
    integer , intent(out) :: status
    double precision :: energy_min, energy_max
    double precision :: norm
    integer :: nodes
    logical :: found
    integer :: ii

    ! debug
    write (*, *) repeat('-', 80)
    write (*, *) "shooting_bisection()"
    write (*, *) "<n_x> = ", int_trim(n_x)
    write (*, *) "<step_size> = ", dp_trim(step_size)
    write (*, *) "<n> = ", int_trim(n)

    ! estimate energy_min, energy_max
    energy_min = 0.0d0
    energy_max = 5.0d0*dble(n+1)*omega

    ! loop
    found = .false.
    ii = 0
    do while ((ii <= MAX_ITERATIONS) .and. (.not. found))
      ii = ii + 1

      ! debug
      write (*, *)
      write (*, *) "iteration: ", int_trim(ii)
      write (*, *) "<energy_min> = ", dp_trim(energy_min, dp=6)
      write (*, *) "<energy_max> = ", dp_trim(energy_max, dp=6)

      energy = (energy_min + energy_max) / 2.0d0

      ! debug
      write (*, *) "<energy> = ", dp_trim(energy)

      ! solve schrodinger differential equation for psi_grid
      call solve_finite_diff(n_x, step_size, v_grid, energy, n, &
          psi_grid, status)

      ! terminate subroutine if solve_finite_diff failed
      if (status /= 0) then
        psi_grid(:) = 0.0d0
        write (*, *) "solve_finite_diff() failed"
        write (*, *) "exiting shooting_bisection"
        return
      end if

      ! count nodes
      nodes = count_nodes(n_x, psi_grid(:))

      ! debug
      write (*, *) "<nodes> = ", int_trim(nodes)

      ! if wrong number of nodes, recalibrate energy_min, energy_max and cycle
      ! otherwise proceed
      if (nodes < n) then
        energy_min = energy

        ! debug
        write (*, *) "too few nodes"
        write (*, *) "setting <energy_min> = ", dp_trim(energy_min)
        write (*, *) "cycling"
        cycle
      else if (nodes > n) then
        energy_max = energy

        ! debug
        write (*, *) "too many nodes"
        write (*, *) "setting <energy_max> = ", dp_trim(energy_max)
        write (*, *) "cycling"
        cycle
      end if

      ! debug
      write (*, *) "correct number of nodes found"

      ! check right-boundary condition
      if (psi_grid(n_x) > 0.0d0) then
        energy_min = energy

        ! debug
        write (*, *) "psi -> +ve infinity"
        write (*, *) "setting <energy_min> = ", dp_trim(energy_min)
      else if (psi_grid(n_x) < 0.0d0) then
        energy_max = energy

        ! debug
        write (*, *) "psi -> -ve infinity"
        write (*, *) "setting <energy_max> = ", dp_trim(energy_max)
      end if

      ! check if convergent
      ! debug
      write (*, *) "<energy_diff> = ", dp_trim(abs(energy_max - energy_min))
      write (*, *) "<psi_grid(n_x)> = ", dp_trim(abs(psi_grid(n_x)))

      if ((abs(energy_max - energy_min) <= TOLERANCE) &
          .or. (abs(psi_grid(n_x)) < TOLERANCE)) then
        found = .true.
      else
        ! debug
        write (*, *) "cycling"
        cycle
      end if
    end do

    ! terminate subroutine if correct nodes not found in time
    ! otherwise proceed
    if (.not. found) then
      ! debug
      call display_graph(n_x, x_grid, psi_grid, width=80, height=30)

      status = -1
      psi_grid(:) = 0.0d0
      write (*, *) "convergent <psi_grid> not found in time"
      write (*, *) "exiting shooting_bisection"
      return
    end if

    ! record iterations
    iterations = ii

    ! with right energy, normalise psi_grid
    norm = sqrt(integrate_trapezoid(n_x, x_grid, (abs(psi_grid(:)) ** 2)))
    psi_grid(:) = psi_grid(:) / norm

    ! debug
    write (*, *) "end shooting_bisection()"
    write (*, *) repeat('-', 80)

  end subroutine shooting_bisection

  ! numerov_cooley
  !
  ! Brief:
  ! For a 1-D Schrodginer equation, this scheme determines the wavefunction and
  ! energy of the n-th eigenstate.
  !
  ! Input:
  ! - `n_x` is the number of grid points.
  ! - `step_size` is the distance between consecutive points on the grid $X$.
  ! - `x_grid` is the grid $X$.
  ! - `v_grid` is the potential plotted on the grid $X$.
  ! - `n` is the index of the eigenstate being searched for.
  !
  ! Output:
  ! - `psi_grid` is the numerically calculated $\psi_{n}(x)$ on the grid $X$.
  ! - `energy` is the numerically calculated energy of $\psi_{n}(x)$.
  ! - `status` integer status code which takes the following values:
  !   - `status == 0` indicates successful execution;
  !   - `status > 0` indicates that the arguments were invalid;
  !   - `status == -1` indicates that a numerical error (NaN or infinity)
  !     occured during execution.
  !
  subroutine numerov_cooley (n_x, step_size, x_grid, omega, v_grid, n, &
      psi_grid, energy, iterations, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: x_grid(n_x)
    double precision , intent(in) :: omega
    double precision , intent(in) :: v_grid(n_x)
    integer , intent(in) :: n
    double precision , intent(out) :: psi_grid(n_x)
    double precision , intent(out) :: energy
    integer , intent(out) :: iterations
    integer , intent(out) :: status
    double precision :: energy_min, energy_max
    double precision :: correction
    double precision :: norm
    integer :: nodes
    logical :: found
    integer :: ii

    ! debug
    write (*, *) repeat('-', 80)
    write (*, *) "numerov_cooley()"
    write (*, *) "<n_x> = ", int_trim(n_x)
    write (*, *) "<step_size> = ", dp_trim(step_size)
    write (*, *) "<n> = ", int_trim(n)

    ! estimate energy_min, energy_max
    energy_min = 0.0d0
    energy_max = 2.0d0*dble(n+1)*omega
    ! energy_min = dble(n)*omega
    ! energy_max = dble(n+1)*omega

    ! loop
    found = .false.
    ii = 0
    do while ((ii <= MAX_ITERATIONS) .and. (.not. found))
      ii = ii + 1

      ! debug
      write (*, *)
      write (*, *) "node-finding iteration: ", int_trim(ii)
      write (*, *) "<energy_min> = ", dp_trim(energy_min, dp=6)
      write (*, *) "<energy_max> = ", dp_trim(energy_max, dp=6)

      energy = (energy_min + energy_max) / 2.0d0

      ! debug
      write (*, *) "<energy> = ", dp_trim(energy)

      ! solve schrodinger differential equation for psi_grid
      ! call solve_finite_diff(n_x, step_size, v_grid, energy, n, &
      !     psi_grid, status)
      call solve_numerov(n_x, step_size, x_grid, v_grid, energy, n, &
          psi_grid, correction, status)

      ! terminate subroutine if solve_finite_diff failed
      if (status /= 0) then
        psi_grid(:) = 0.0d0
        write (*, *) "solve_finite_diff() failed"
        write (*, *) "exiting numerov_cooley()"
        return
      end if

      ! count nodes
      nodes = count_nodes(n_x, psi_grid(:))

      ! debug
      write (*, *) "<nodes> = ", int_trim(nodes)

      ! if wrong number of nodes, recalibrate energy_min, energy_max and cycle
      ! otherwise proceed
      if (nodes < n) then
        energy_min = energy

        ! debug
        write (*, *) "too few nodes"
        write (*, *) "setting <energy_min> = ", dp_trim(energy_min)
        write (*, *) "cycling"
        cycle
      else if (nodes > n) then
        energy_max = energy

        ! debug
        write (*, *) "too many nodes"
        write (*, *) "setting <energy_max> = ", dp_trim(energy_max)
        write (*, *) "cycling"
        cycle
      else
        found = .true.
      end if
    end do

    ! terminate subroutine if correct nodes not found in time
    if (.not. found) then
      status = -1
      psi_grid(:) = 0.0d0
      write (*, *) "correct nodes not found in time"
      write (*, *) "exiting numerov_cooley"
      return
    end if

    ! ! debug
    ! call display_graph(n_x, x_grid, psi_grid, width=80, height=30)

    ! debug
    write (*, *) "correct number of nodes found"
    write (*, *) "<energy> = ", dp_trim(energy, dp=6)

    ! record node-finding iterations
    iterations = ii

    ! with right number of nodes, determine correct energy using cooley
    found = .false.
    ii = 0
    do while ((ii <= MAX_ITERATIONS) .and. (.not. found))
      ii = ii + 1

      ! debug
      write (*, *)
      write (*, *) "energy-finding iteration: ", int_trim(ii)

      call solve_numerov(n_x, step_size, x_grid, v_grid, energy, n, &
          psi_grid, correction, status)

      ! debug
      write (*, *) "<energy> = ", dp_trim(energy, dp=6)
      write (*, *) "<correction> = ", dp_trim(correction, dp=6)

      ! ! debug
      ! call display_graph(n_x, x_grid, psi_grid, width=80, height=30)

      ! terminate subroutine if solve_numerov failed
      if (status /= 0) then
        psi_grid(:) = 0.0d0
        write (*, *) "solve_numerov() failed"
        write (*, *) "exiting numerov_cooley()"
        return
      end if

      energy = energy + correction

      found = (abs(correction) < TOLERANCE)
    end do

    ! terminate subroutine if convergent energy not found in time
    if (.not. found) then
      status = -1
      write (*, *) "convergent energy not found in time"
      write (*, *) "exiting numerov_cooley()"
      return
    end if

    ! record energy-finding iterations
    iterations = iterations + ii

    ! with right energy, normalise psi_grid
    norm = sqrt(integrate_trapezoid(n_x, x_grid, (abs(psi_grid(:)) ** 2)))
    psi_grid(:) = psi_grid(:) / norm

    ! ! debug
    ! call display_graph(n_x, x_grid, psi_grid)

    ! debug
    write (*, *) "end numerov_cooley()"
    write (*, *) repeat('-', 80)

  end subroutine numerov_cooley

  ! solve_finite_diff
  subroutine solve_finite_diff (n_x, step_size, v_grid, energy, n, &
      psi_grid, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: v_grid(n_x)
    double precision , intent(in) :: energy
    integer , intent(in) :: n
    double precision , intent(out) :: psi_grid(n_x)
    integer , intent(out) :: status
    integer :: ii

    ! debug
    write (*, *) "solve_finite_diff()"
    ! write (*, *) "<n_x> = ", int_trim(n_x)
    ! write (*, *) "<step_size> = ", dp_trim(step_size)
    ! write (*, *) "<energy> = ", dp_trim(energy)
    ! write (*, *) "<n> = ", int_trim(n)

    ! check if arguments are valid
    status = 0

    if (n_x < 1) then
      ! no grid points
      status = 1
    end if

    if (step_size < 0.0d0) then
      ! non-positive step_size
      status = 2
    end if

    ! terminate subroutine if arguments are invalid, otherwise proceed
    if (status /= 0) then
      psi_grid(:) = 0.0d0
      return
    end if

    ! set up left-boundary conditions
    psi_grid(1) = 0.0d0
    psi_grid(2) = SMALL*((-1) ** (n))

    ! solve forwards using finite difference method
    do ii = 2, n_x-1
      psi_grid(ii+1) = &
          2.0d0*((step_size ** 2)*(v_grid(ii)-energy) + 1.0d0)*psi_grid(ii) &
          - psi_grid(ii-1)

      ! check for and handle numerical error (NaN or Infinity) and terminates
      if ((psi_grid(ii+1) /= psi_grid(ii+1)) &
          .or. (psi_grid(ii+1) > INFINITY)) then
        status = -1
        if (ii + 2 <= n_x) then
          psi_grid(ii+2:n_x) = 0.0d0
        end if
        return
      end if
    end do

    ! debug
    write (*, *) "end solve_finite_diff()"

  end subroutine solve_finite_diff

  ! solve_numerov
  !
  ! Brief:
  ! The 1-D Schrodinger equation, with the Hamiltonian
  ! $$ - 0.5*\psi''(x) + V(x)*\psi(x) = E*\psi(x) $$ ,
  ! is solved for bound wavefunctions using the forwards and backwards Numerov
  ! method.
  ! The potential must be evaluated on a grid $X$, consisting of points
  ! consecutively equidistant.
  ! The predicted energy and number of nodes are required.
  ! The calculated wavefunction is not normalised.
  !
  ! Input:
  ! - `n_x` is the number of grid points.
  ! - `step_size` is the distance between consecutive points on the grid $X$.
  ! - `v_grid` is the potential plotted on the grid $X$.
  ! - `energy` is the predicted energy of $\psi_{n}(x)$.
  ! - `n` is the predicted number of nodes of $\psi_{n}(x)$.
  !
  ! Output:
  ! - `psi_grid` is the numerically calculated $\psi_{n}(x)$ on the grid $X$.
  ! - `correction` is the numerically calculated Cooley's energy correction.
  ! - `status` integer status code which takes the following values:
  !   - `status == 0` indicates successful execution;
  !   - `status > 0` indicates that the arguments were invalid;
  !   - `status == -1` indicates that a numerical error (NaN or infinity)
  !     occured during execution.
  !
  subroutine solve_numerov (n_x, step_size, x_grid, v_grid, energy, n, &
      psi_grid, correction, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: x_grid(n_x)
    double precision , intent(in) :: v_grid(n_x)
    double precision , intent(in) :: energy
    integer , intent(in) :: n
    double precision , intent(out) :: psi_grid(n_x)
    double precision , intent(out) :: correction
    integer , intent(out) :: status
    double precision :: g_grid(n_x), s_grid(n_x)
    double precision :: psi_l_grid(n_x), psi_r_grid(n_x), temp(n_x)
    logical :: matched
    integer :: i_m
    integer :: ii

    ! debug
    write (*, *) "solve_numerov()"
    ! write (*, *) "<n_x> = ", int_trim(n_x)
    ! write (*, *) "<step_size> = ", dp_trim(step_size)
    ! write (*, *) "<energy> = ", dp_trim(energy)
    ! write (*, *) "<n> = ", int_trim(n)

    ! check if arguments are valid
    status = 0

    if (n_x < 1) then
      ! no grid points
      status = 1
    end if

    if (step_size < 0.0d0) then
      ! non-positive step_size
      status = 2
    end if

    ! terminate subroutine if arguments are invalid, otherwise proceed
    if (status /= 0) then
      psi_grid(:) = 0.0d0
      return
    end if

    ! set up g(x), s(x) for calls to numerov
    g_grid(:) = -2.0d0*(v_grid(:) - energy)
    s_grid(:) = 0.0d0

    ! set up boundary conditions
    psi_grid(1) = 0.0d0
    psi_grid(2) = SMALL * dble((-1) ** n)
    psi_grid(3:n_x-2) = 0.0d0
    psi_grid(n_x-1) = SMALL
    psi_grid(n_x) = 0.0d0

    ! solve forwards numerov
    psi_l_grid(:) = psi_grid(:)
    call numerov_f(n_x, step_size, s_grid, g_grid, psi_l_grid, status)

    ! terminate subroutine if numerov_f failed
    if (status /= 0) then
      psi_grid(:) = 0.0d0
      write (*, *) "numerov_f() failed"
      write (*, *) "exiting solve_numerov()"
      return
    end if

    ! solve backwards numerov
    psi_r_grid(:) = psi_grid(:)
    call numerov_b(n_x, step_size, s_grid, g_grid, psi_r_grid, status)

    ! terminate subroutine if numerov_b failed
    if (status /= 0) then
      psi_grid(:) = 0.0d0
      write (*, *) "numerov_b() failed"
      write (*, *) "exiting solve_numerov()"
      return
    end if

    ! locate where psi_l and psi_r match up
    i_m = minloc(abs(psi_l_grid(:) - psi_r_grid(:)), 1)

    matched = .false.
    do while ((i_m <= n_x) .and. (.not. matched))
      matched = (abs(psi_l_grid(i_m)) > SMALL) &
          .and. (abs(psi_r_grid(i_m)) > SMALL)

      if (.not. matched) i_m = i_m + 1
    end do

    ! terminate subroutine if psi_l, psi_r could not be matched
    if (.not. matched) then
      status = -2
      psi_grid(:) = 0.0d0
      write (*, *) "failed to match"
      write (*, *) "<psi_l_grid>"
      ! call display_vector(n_x, psi_l_grid)
      call display_graph(n_x, x_grid, psi_l_grid)
      write (*, *) "<psi_r_grid>"
      ! call display_vector(n_x, psi_r_grid)
      call display_graph(n_x, x_grid, psi_r_grid)
      write (*, *) "exiting solve_numerov()"
      return
    end if

    ! stich psi together from psi_l, psi_r
    do ii = 1, i_m
      psi_grid(ii) = psi_l_grid(ii) / psi_l_grid(i_m)
    end do

    do ii = i_m+1, n_x
      psi_grid(ii) = psi_r_grid(ii) / psi_r_grid(i_m)
    end do

    ! ! debug
    ! write (*, *) "<psi_grid>"
    ! call display_graph(n_x, x_grid, psi_grid)

    ! calculate cooley's energy correction
    correction = cooley_correction(n_x, step_size, v_grid, energy, &
        psi_grid, i_m)

    write (*, *) "<correction> = ", dp_trim(correction, dp=6)

    ! debug
    write (*, *) "end solve_numerov()"

  end subroutine solve_numerov

  function cooley_correction (n_x, step_size, v_grid, energy, &
      psi_grid, i_m) result (correction)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: v_grid(n_x)
    double precision , intent(in) :: energy
    double precision , intent(in) :: psi_grid(n_x)
    integer , intent(in) :: i_m
    double precision :: correction
    double precision :: g_grid(n_x), y_grid(0:n_x+1), temp_grid(n_x)
    double precision :: overlap, energy_diff, numerov_term
    integer :: ii

    ! debug
    ! write (*, *) "cooley_correction()"

    ! grid variables
    g_grid(:) = -2.0d0*(v_grid(:) - energy)

    y_grid(0) = 0.0d0
    do ii = 1, n_x
      y_grid(ii) = (1.0d0 + (((step_size ** 2)*g_grid(ii))/12.0d0))*psi_grid(ii)
    end do
    y_grid(n_x+1) = 0.0d0

    ! calculate overlap
    overlap = 0.0d0
    do ii = 1, n_x
      overlap = overlap + (abs(psi_grid(ii)) ** 2)
    end do
    overlap = overlap*step_size

    !general method
    temp_grid(1) = 0.0d0
    temp_grid(n_x) = 0.0d0
    energy_diff = 0.0d0
    do ii = 2, n_x-1
      numerov_term = y_grid(ii+1) - 2.0d0*y_grid(ii) + y_grid(ii-1)

      temp_grid(ii) = ((v_grid(ii) - energy)*psi_grid(ii)) &
          - ((0.5d0*numerov_term)/(step_size ** 2))
      energy_diff = energy_diff + (psi_grid(ii) * temp_grid(ii))
    end do
    energy_diff=energy_diff*step_size

    ! ! specific method
    ! numerov_term = y_grid(i_m+1) - 2.0d0*y_grid(i_m) + y_grid(i_m-1)

    ! energy_diff = psi_grid(i_m)*( &
    !     (v_grid(i_m) - energy)*psi_grid(i_m) &
    !     - ((0.5d0*numerov_term)/(step_size ** 2)))
    ! energy_diff=energy_diff*step_size

    correction = energy_diff / overlap

    ! debug
    ! write (*, *) "<overlap> = ", dp_trim(overlap, dp=6)
    ! write (*, *) "<energy_diff> = ", dp_trim(energy_diff, dp=6)
    ! write (*, *) "<correction> = ", dp_trim(correction, dp=6)
    ! write (*, *) "end cooley_correction()"

  end function cooley_correction

  ! count_nodes
  !
  ! Brief:
  ! Counts the number of nodes in an evaluated function.
  function count_nodes (n_x, psi_grid) result (nodes)
    integer , intent(in) :: n_x
    double precision , intent(in) :: psi_grid(n_x)
    integer :: nodes
    integer :: definite_nodes, possible_nodes
    integer :: sgn(n_x)
    integer :: ii, jj

    ! debug
    write (*, *) "count_nodes()"

    ! method: sign change advanced
    where (abs(psi_grid(:)) <= SMALL*1d1)
      sgn(:) = 0
    elsewhere (psi_grid(:) > SMALL*1d1)
      sgn(:) = 1
    elsewhere (psi_grid(:) < SMALL*1d1)
      sgn(:) = -1
    endwhere

    ! ! debug
    ! do ii = 1, n_x
    !   write (*, *) ii, psi_grid(ii), sgn(ii)
    ! end do

    ! initialise node counting
    nodes = 0
    possible_nodes = 0
    definite_nodes = 0

    ! loop through sgn(:) to find sign changes
    ii = 1
    do while (ii < n_x)
      ! write (*, *) "ii, sgn, psi = ", ii, sgn(ii), psi_grid(ii)

      ! search for first definitively non-zero point
      if (sgn(ii) == 0) then
        ! write (*, *) "cycling for non-zero point"
        ii = ii + 1
        cycle
      end if

      ! write (*, *) "is non-zero"

      ! check if next step has change in sgn(:)
      if (sgn(ii) /= sgn(ii+1)) then
        ! write (*, *) "change at ", int_trim(ii), &
        !     " (", dp_trim(psi_grid(ii)), " -> ", dp_trim(psi_grid(ii+1)), ")"

        possible_nodes = possible_nodes + 1

        ! step past a run of zero or more 0s
        jj = ii + 1
        do while (jj <= n_x)
          ! write (*, *) "zero run: ", jj, sgn(jj)
          if (sgn(jj) == 0) then
            ! write (*, *) "continues"
            jj = jj + 1
          else
            ! write (*, *) "finishes"
            exit
          end if
        end do
        ! write (*, *) "run of ", int_trim(jj - ii - 1), " zeroes"

        ! if sign has changed, is definitely a nodal region
        if (jj <= n_x) then
          if (sgn(jj) == -sgn(ii)) then
            definite_nodes = definite_nodes + 1
          end if
        end if

        ii = jj
      else
        ii = ii + 1
      end if
    end do

    nodes = definite_nodes
    ! nodes = possible_nodes

    ! debug
    ! write (*, *) "definite_nodes = ", int_trim(definite_nodes)
    ! write (*, *) "possible_nodes = ", int_trim(possible_nodes)
    ! write (*, *) "nodes = ", int_trim(nodes)
    write (*, *) "nodes = ", int_trim(nodes), &
        " (", int_trim(definite_nodes), " def / ", &
        int_trim(possible_nodes), " pos)"

    ! debug
    write (*, *) "end count_nodes()"

  end function count_nodes

end module m_schrodinger


      SUBROUTINE XYZSPH(KEY,ANG1,ANG2,MAG,CART,FACTR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE DOES CONVERSIONS BETWEEN SPHERICAL AND CARTESIAN COORDS.
C
C     THE ANG1/ANG2 PAIR IS RACN/DECL, AZ/EL, LONG/LAT,........
C
C  KEY=NEGATIVE -- GET ANG1, ANG2, AND MAGNITUDE OF THE
C                  VECTOR FACTR*CART.
C
C  KEY=ZERO OR POSITIVE -- GET THE CARTESIAN VECTOR XCART FROM THE
C                  VECTOR HAVING DIRECTION ANG1/ANG2, AND
C                  HAVING MAGNITUDE MAG. RETURN CART=FACTR*XCART.
C
C*********************************************************************
C
C  INPUT/OUTPUT....
C
C  VARIABLE  DIM  TYPE  I/O    DESCRIPTION
C  --------  ---  ----  ---    -----------
C
C     WHEN CONVERTING A CARTESIAN VECTOR TO ANGLES AND MAGNITUDE:
C
C  KEY       1    I*4    I     MUST BE NEGATIVE. INDICATES THAT ANGLES
C                              AND MAGNITUDE ARE BEING COMPUTED.
C
C  ANG1      1    R*8    O     FIRST ANGLE IN RACN/DECL, AZ/EL,
C                              LONG/LAT, ETC., PAIR. RADIANS.
C                              ANG1/ANG2 ARE COMPUTED FOR THE VECTOR
C                              FACTR*CART. USUALLY ONE USES FACTR=1.D0
C
C  ANG2      1    R*8    O     SECOND ANGLE IN THE PAIR. RADIANS.
C
C  MAG       1    R*8    O     MAGNITUDE OF THE VECTOR THAT WAS INPUT.
C
C  CART      3    R*8    I     THE CARTESIAN VECTOR INPUT.
C
C  FACTR     1    R*8    I     THE FACTOR BY WHICH CART IS MULTIPLIED
C                              BEFORE THE ANG1/ANG2/MAG VALUES FOR THE
C                              FACTR*CART PRODUCT ARE COMPUTED. USUALLY
C                              FACTR=1.D0 IS USED.
C
C+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
C
C     WHEN CONVERTING ANGLES AND MAGNITUDE TO CARTESIAN VECTOR:
C
C  KEY       1    I*4    I     MUST BE ZERO OR POSITIVE. THIS INDICATES
C                              THAT A CARTESIAN VECTOR IS BEING COMPUTED
C
C  ANG1      1    R*8    I     FIRST ANGLE IN THE ANGLE PAIR. RADIANS.
C
C  ANG2      1    R*8    I     SECOND ANGLE IN THE PAIR. RADIANS.
C
C  MAG       1    R*8    I     MAGNITUDE OF THE VECTOR TO BE OUTPUT.
C
C  CART      3    R*8    O     CARTESIAN VECTOR COMPUTED FROM PRODUCT
C                              OF FACTR AND THE VECTOR DESCRIBED BY
C                              THE ANGLES AND MAGNITUDE INPUT. USUALLY
C                              FACTR=1.D0 IS USED.
C
C  FACTR     1    R*8    I     MULTIPLICATION FACTOR FOR THE OUTPUT
C                              VECTOR. USUALLY 1.D0 IS USED.
C
C********************************************************************
C
C   CODED BY CHARLIE PETRUZZO   6/81.
C     MODIFIED......
C
C
C
      REAL*8 TWOPI/  6.283185307179586D0    /
      REAL*8 CART(3),MAG,TEMP(3)
C
      IF(KEY.LT.0) GO TO 100
C
C     KEY IS ZERO OR POSITIVE.  GET CARTESIAN VECTOR.
C
      FACTX=MAG*FACTR
      COSDEC=DCOS(ANG2)
      CART(1) = COSDEC * DCOS(ANG1) * FACTX
      CART(2) = COSDEC * DSIN(ANG1) * FACTX
      CART(3) = DSIN(ANG2) * FACTX
      GO TO 900
C
C
  100 CONTINUE
C
C     KEY IS NEGATIVE. GET ANGLES AND MAGNITUDE.
C
      TEMP(1) = CART(1) * FACTR
      TEMP(2) = CART(2) * FACTR
      TEMP(3) = CART(3) * FACTR
      MAG=DSQRT(TEMP(1)**2+TEMP(2)**2+TEMP(3)**2)
      ANG2=0.D0
      IF(MAG.NE.0.D0) ANG2=DASIN(TEMP(3)/MAG)
      ANG1=0.D0
      IF(TEMP(1).NE.0.D0 .OR. TEMP(2).NE.0.D0) ANG1=DMOD(DATAN2(TEMP(2),
     1           TEMP(1))+TWOPI,TWOPI)
C
C
  900 CONTINUE
      RETURN
      END


*DECK POIS3D
      SUBROUTINE POIS3D (LPEROD, L, C1, MPEROD, M, C2, NPEROD, N, A, B,
     +   C, LDIMF, MDIMF, F, IERROR, W)
C***BEGIN PROLOGUE  POIS3D
C***PURPOSE  Solve a three-dimensional block tridiagonal linear system
C            which arises from a finite difference approximation to a
C            three-dimensional Poisson equation using the Fourier
C            transform package FFTPAK written by Paul Swarztrauber.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B4B
C***TYPE      SINGLE PRECISION (POIS3D-S)
C***KEYWORDS  ELLIPTIC PDE, FISHPACK, HELMHOLTZ, POISSON
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine POIS3D solves the linear system of equations
C
C       C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K))
C     + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K))
C     + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K)
C
C     for  I=1,2,...,L , J=1,2,...,M , and K=1,2,...,N .
C
C     The indices K-1 and K+1 are evaluated modulo N, i.e.
C     X(I,J,0) = X(I,J,N) and X(I,J,N+1) = X(I,J,1). The unknowns
C     X(0,J,K), X(L+1,J,K), X(I,0,K), and X(I,M+1,K) are assumed to take
C     on certain prescribed values described below.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C
C            * * * * * *   On Input    * * * * * *
C
C     LPEROD   Indicates the values that X(0,J,K) and X(L+1,J,K) are
C              assumed to have.
C
C              = 0  If X(0,J,K) = X(L,J,K) and X(L+1,J,K) = X(1,J,K).
C              = 1  If X(0,J,K) = X(L+1,J,K) = 0.
C              = 2  If X(0,J,K) = 0  and X(L+1,J,K) = X(L-1,J,K).
C              = 3  If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = X(L-1,J,K).
C              = 4  If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = 0.
C
C     L        The number of unknowns in the I-direction. L must be at
C              least 3.
C
C     C1       The real constant that appears in the above equation.
C
C     MPEROD   Indicates the values that X(I,0,K) and X(I,M+1,K) are
C              assumed to have.
C
C              = 0  If X(I,0,K) = X(I,M,K) and X(I,M+1,K) = X(I,1,K).
C              = 1  If X(I,0,K) = X(I,M+1,K) = 0.
C              = 2  If X(I,0,K) = 0 and X(I,M+1,K) = X(I,M-1,K).
C              = 3  If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = X(I,M-1,K).
C              = 4  If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = 0.
C
C     M        The number of unknowns in the J-direction. M must be at
C              least 3.
C
C     C2       The real constant which appears in the above equation.
C
C     NPEROD   = 0  If A(1) and C(N) are not zero.
C              = 1  If A(1) = C(N) = 0.
C
C     N        The number of unknowns in the K-direction. N must be at
C              least 3.
C
C
C     A,B,C    One-dimensional arrays of length N that specify the
C              coefficients in the linear equations given above.
C
C              If NPEROD = 0 the array elements must not depend upon the
C              index K, but must be constant.  Specifically, the
C              subroutine checks the following condition
C
C                          A(K) = C(1)
C                          C(K) = C(1)
C                          B(K) = B(1)
C
C                  for K=1,2,...,N.
C
C     LDIMF    The row (or first) dimension of the three-dimensional
C              array F as it appears in the program calling POIS3D.
C              This parameter is used to specify the variable dimension
C              of F.  LDIMF must be at least L.
C
C     MDIMF    The column (or second) dimension of the three-dimensional
C              array F as it appears in the program calling POIS3D.
C              This parameter is used to specify the variable dimension
C              of F.  MDIMF must be at least M.
C
C     F        A three-dimensional array that specifies the values of
C              the right side of the linear system of equations given
C              above.  F must be dimensioned at least L x M x N.
C
C     W        A one-dimensional array that must be provided by the
C              user for work space.  The length of W must be at least
C              30 + L + M + 2*N + MAX(L,M,N) +
C              7*(INT((L+1)/2) + INT((M+1)/2)).
C
C
C            * * * * * *   On Output   * * * * * *
C
C     F        Contains the solution X.
C
C     IERROR   An error flag that indicates invalid input parameters.
C              Except for number zero, a solution is not attempted.
C              = 0  No error
C              = 1  If LPEROD .LT. 0 or .GT. 4
C              = 2  If L .LT. 3
C              = 3  If MPEROD .LT. 0 or .GT. 4
C              = 4  If M .LT. 3
C              = 5  If NPEROD .LT. 0 or .GT. 1
C              = 6  If N .LT. 3
C              = 7  If LDIMF .LT. L
C              = 8  If MDIMF .LT. M
C              = 9  If A(K) .NE. C(1) or C(K) .NE. C(1) or B(I) .NE.B(1)
C                      for some K=1,2,...,N.
C              = 10 If NPEROD = 1 and A(1) .NE. 0 or C(N) .NE. 0
C
C              Since this is the only means of indicating a possibly
C              incorrect call to POIS3D, the user should test IERROR
C              after the call.
C
C *Long Description:
C
C    * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   A(N),B(N),C(N),F(LDIMF,MDIMF,N),
C     Arguments      W(see argument list)
C
C     Latest         December 1, 1978
C     Revision
C
C     Subprograms    POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1,RFFTB,
C     Required       RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1
C                    COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1,
C                    CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF,
C                    CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH,
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet at NCAR in July 1977
C
C     Algorithm      This subroutine solves three-dimensional block
C                    tridiagonal linear systems arising from finite
C                    difference approximations to three-dimensional
C                    Poisson equations using the Fourier transform
C                    package FFTPAK written by Paul Swarztrauber.
C
C     Space          6561(decimal) = 14641(octal) locations on the
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine POIS3D is roughly proportional
C                    to L*M*N*(log2(L)+log2(M)+5), but also depends on
C                    input parameters LPEROD and MPEROD.  Some typical
C                    values are listed in the table below when NPEROD=0.
C                       To measure the accuracy of the algorithm a
C                    uniform random number generator was used to create
C                    a solution array X for the system given in the
C                    'PURPOSE' with
C
C                       A(K) = C(K) = -0.5*B(K) = 1,       K=1,2,...,N
C
C                    and, when NPEROD = 1
C
C                       A(1) = C(N) = 0
C                       A(N) = C(1) = 2.
C
C                    The solution X was substituted into the given sys-
C                    tem and, using double precision, a right side Y was
C                    computed.  Using this array Y subroutine POIS3D was
C                    called to produce an approximate solution Z.  Then
C                    the relative error, defined as
C
C                    E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K)))
C
C                    where the two maxima are taken over I=1,2,...,L,
C                    J=1,2,...,M and K=1,2,...,N, was computed.  The
C                    value of E is given in the table below for some
C                    typical values of L,M and N.
C
C
C                       L(=M=N)   LPEROD    MPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         16        0         0         272     1.E-13
C                         15        1         1         287     4.E-13
C                         17        3         3         338     2.E-13
C                         32        0         0        1755     2.E-13
C                         31        1         1        1894     2.E-12
C                         33        3         3        2042     7.E-13
C
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS,SIN,ATAN
C     Resident
C     Routines
C
C     Reference      NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  POS3D1
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  POIS3D
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,
     1                F(LDIMF,MDIMF,*)       ,W(*)       ,SAVE(6)
C***FIRST EXECUTABLE STATEMENT  POIS3D
      LP = LPEROD+1
      MP = MPEROD+1
      NP = NPEROD+1
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
      IF (L .LT. 3) IERROR = 2
      IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
      IF (M .LT. 3) IERROR = 4
      IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
      IF (N .LT. 3) IERROR = 6
      IF (LDIMF .LT. L) IERROR = 7
      IF (MDIMF .LT. M) IERROR = 8
      IF (NP .NE. 1) GO TO 103
      DO 101 K=1,N
         IF (A(K) .NE. C(1)) GO TO 102
         IF (C(K) .NE. C(1)) GO TO 102
         IF (B(K) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 9
  103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
  104 IF (IERROR .NE. 0) GO TO 122
      IWYRT = L+1
      IWT = IWYRT+M
      IWD = IWT+MAX(L,M,N)+1
      IWBB = IWD+N
      IWX = IWBB+N
      IWY = IWX+7*((L+1)/2)+15
      GO TO (105,114),NP
C
C     REORDER UNKNOWNS WHEN NPEROD = 0.
C
  105 NH = (N+1)/2
      NHM1 = NH-1
      NODD = 1
      IF (2*NH .EQ. N) NODD = 2
      DO 111 I=1,L
         DO 110 J=1,M
            DO 106 K=1,NHM1
               NHPK = NH+K
               NHMK = NH-K
               W(K) = F(I,J,NHMK)-F(I,J,NHPK)
               W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
  106       CONTINUE
            W(NH) = 2.*F(I,J,NH)
            GO TO (108,107),NODD
  107       W(N) = 2.*F(I,J,N)
  108       DO 109 K=1,N
               F(I,J,K) = W(K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      SAVE(1) = C(NHM1)
      SAVE(2) = A(NH)
      SAVE(3) = C(NH)
      SAVE(4) = B(NHM1)
      SAVE(5) = B(N)
      SAVE(6) = A(N)
      C(NHM1) = 0.
      A(NH) = 0.
      C(NH) = 2.*C(NH)
      GO TO (112,113),NODD
  112 B(NHM1) = B(NHM1)-A(NH-1)
      B(N) = B(N)+A(N)
      GO TO 114
  113 A(N) = C(NH)
  114 CONTINUE
      CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
     1             W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
      GO TO (115,122),NP
  115 DO 121 I=1,L
         DO 120 J=1,M
            DO 116 K=1,NHM1
               NHMK = NH-K
               NHPK = NH+K
               W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
               W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
  116       CONTINUE
            W(NH) = .5*F(I,J,NH)
            GO TO (118,117),NODD
  117       W(N) = .5*F(I,J,N)
  118       DO 119 K=1,N
               F(I,J,K) = W(K)
  119       CONTINUE
  120    CONTINUE
  121 CONTINUE
      C(NHM1) = SAVE(1)
      A(NH) = SAVE(2)
      C(NH) = SAVE(3)
      B(NHM1) = SAVE(4)
      B(N) = SAVE(5)
      A(N) = SAVE(6)
  122 CONTINUE
      RETURN
      END


INTEGER FUNCTION gaussian3d() RESULT(r)
  USE FEQParse
  IMPLICIT NONE

  TYPE(EquationParser) :: f
  CHARACTER(LEN=1), DIMENSION(1:3) :: independentVars
  CHARACTER(LEN=30) :: eqChar
  REAL :: x(1:3)

    ! Specify the independent variables
    independentVars = (/ 'x', 'y', 'z' /)

    ! Specify an equation string that we want to evaluate
    eqChar = 'f = exp( -(x^2 + y^2 + z^2) )'

    ! Create the EquationParser object
    f = EquationParser(eqChar, independentVars)

    ! Evaluate the equation
    x = (/ 0.0, 0.0, 0.0 /)
    IF( ABS(f % evaluate( x ) - 1.0) <= epsilon(1.0) )THEN
      r = 0
    ELSE
      r = 1
    ENDIF

    ! Clean up memory
    CALL f % Destruct()

END FUNCTION gaussian3d


! Works with gfortran but needs the option
!   -assume realloc_lhs
! when compiled with Intel Fortran.

program gauss
  implicit none
  integer, parameter :: p = 16 ! quadruple precision
  integer            :: n = 10, k
  real(kind=p), allocatable :: r(:,:)
  real(kind=p)       :: z, a, b, exact
  do n = 1,20
    a = -3; b = 3
    r = gaussquad(n)
    z = (b-a)/2*dot_product(r(2,:),exp((a+b)/2+r(1,:)*(b-a)/2))
    exact = exp(3.0_p)-exp(-3.0_p)
    print "(i0,1x,g0,1x,g10.2)",n, z, z-exact
  end do

  contains

  function gaussquad(n) result(r)
  integer                 :: n
  real(kind=p), parameter :: pi = 4*atan(1._p)
  real(kind=p)            :: r(2, n), x, f, df, dx
  integer                 :: i,  iter
  real(kind = p), allocatable :: p0(:), p1(:), tmp(:)

  p0 = [1._p]
  p1 = [1._p, 0._p]

  do k = 2, n
     tmp = ((2*k-1)*[p1,0._p]-(k-1)*[0._p, 0._p,p0])/k
     p0 = p1; p1 = tmp
  end do
  do i = 1, n
    x = cos(pi*(i-0.25_p)/(n+0.5_p))
    do iter = 1, 10
      f = p1(1); df = 0._p
      do k = 2, size(p1)
        df = f + x*df
        f  = p1(k) + x * f
      end do
      dx =  f / df
      x = x - dx
      if (abs(dx)<10*epsilon(dx)) exit
    end do
    r(1,i) = x
    r(2,i) = 2/((1-x**2)*df**2)
  end do
  end function
end program