MODULE luxury

!     Subtract-and-borrow random number generator proposed by
!     Marsaglia and Zaman, implemented by F. James with the name
!     RCARRY in 1991, and later improved by Martin Luescher
!     in 1993 to produce "Luxury Pseudorandom Numbers".
!     Fortran 77 coded by F. James, 1993

!  References:
!  M. Luscher, Computer Physics Communications  79 (1994) 100
!  F. James, Computer Physics Communications 79 (1994) 111

!     This Fortran 90 version is by Alan Miller (alan @ mel.dms.csiro.au)
!     Latest revision - 11 September 1995

!   LUXURY LEVELS.
!   ------ ------      The available luxury levels are:

!  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
!           and Zaman, very long period, but fails many tests.
!  level 1  (p=48): considerable improvement in quality over level 0,
!           now passes the gap test, but still fails spectral test.
!  level 2  (p=97): passes all known tests, but theoretically still
!           defective.
!  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
!           correlations have very small chance of being observed.
!  level 4  (p=389): highest possible luxury, all 24 bits chaotic.

!!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!!!!  Calling sequences for RANLUX:                                  ++
!!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
!!!!                   32-bit random floating point numbers between  ++
!!!!                   zero (not included) and one (also not incl.). ++
!!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
!!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
!!!!               which is integer between zero and MAXLEV, or if   ++
!!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
!!!!               should be set to zero unless restarting at a break++
!!!!               point given by output of RLUXAT (see RLUXAT).     ++
!!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
!!!!               which can be used to restart the RANLUX generator ++
!!!!               at the current point by calling RLUXGO.  K1 and K2++
!!!!               specify how many numbers were generated since the ++
!!!!               initialization with LUX and INT.  The restarting  ++
!!!!               skips over  K1+K2*E9   numbers, so it can be long.++
!!!!   A more efficient but less convenient way of restarting is by: ++
!!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
!!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
!!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
!!!!                 32-bit integer seeds, to be used for restarting ++
!!!!      ISVEC must be dimensioned 25 in the calling program        ++
!!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

IMPLICIT NONE

INTEGER            :: isdext(25)
INTEGER, PARAMETER :: maxlev = 4, lxdflt = 3, jsdflt = 314159265
INTEGER            :: ndskip(0:maxlev) = (/ 0, 24, 73, 199, 365 /)
INTEGER            :: igiga = 1000000000, i24 = 24, j24 = 10
REAL, PARAMETER    :: twop12 = 4096.
INTEGER, PARAMETER :: itwo24 = 2**24, icons = 2147483563
INTEGER, SAVE      :: next(24), luxlev = lxdflt, nskip, inseed, jseed
LOGICAL, SAVE      :: notyet = .true.
INTEGER            :: in24 = 0, kount = 0, mkount = 0
REAL, SAVE         :: seeds(24), carry = 0., twom24, twom12

!                            default
!  Luxury Level     0   1   2  *3*    4
!    ndskip        /0, 24, 73, 199, 365/
! Corresponds to p=24  48  97  223  389
!     time factor   1   2   3    6   10   on slow workstation
!                   1 1.5   2    3    5   on fast mainframe
!                   1 1.5 2.5    5  8.5   on PC using LF90

PUBLIC notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
PUBLIC nskip, ndskip, in24, next, kount, mkount, inseed

CONTAINS

SUBROUTINE ranlux(rvec, lenv)

IMPLICIT NONE

INTEGER, INTENT(IN) :: lenv
REAL, INTENT(OUT)   :: rvec(lenv)

!     Local variables

INTEGER             :: i, k, lp, ivec, iseeds(24), isk
REAL                :: uni

!  NOTYET is .TRUE. if no initialization has been performed yet.
!              Default Initialization by Multiplicative Congruential

IF (notyet) THEN
  notyet = .false.
  jseed = jsdflt
  inseed = jseed
  WRITE (6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ', jseed
  luxlev = lxdflt
  nskip = ndskip(luxlev)
  lp = nskip + 24
  in24 = 0
  kount = 0
  mkount = 0
  WRITE (6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL =  ', luxlev,   &
                          '    p =', lp
  twom24 = 1.
  DO i = 1, 24
    twom24 = twom24 * 0.5
    k = jseed / 53668
    jseed = 40014 * (jseed-k*53668) - k * 12211
    IF (jseed.LT.0) jseed = jseed + icons
    iseeds(i) = MOD(jseed,itwo24)
  END DO
  twom12 = twom24 * 4096.
  DO i = 1, 24
    seeds(i) = REAL(iseeds(i)) * twom24
    next(i) = i - 1
  END DO
  next(1) = 24
  i24 = 24
  j24 = 10
  carry = 0.
  IF (seeds(24).EQ.0.) carry = twom24
END IF

!          The Generator proper: "Subtract-with-borrow",
!          as proposed by Marsaglia and Zaman,
!          Florida State University, March, 1989

DO ivec = 1, lenv
  uni = seeds(j24) - seeds(i24) - carry
  IF (uni.LT.0.) THEN
    uni = uni + 1.0
    carry = twom24
  ELSE
    carry = 0.
  END IF
  seeds(i24) = uni
  i24 = next(i24)
  j24 = next(j24)
  rvec(ivec) = uni
!  small numbers (with less than 12 "significant" bits) are "padded".
  IF (uni.LT.twom12) THEN
    rvec(ivec) = rvec(ivec) + twom24 * seeds(j24)
!        and zero is forbidden in case someone takes a logarithm
    IF (rvec(ivec).EQ.0.) rvec(ivec) = twom24 * twom24
  END IF
!        Skipping to luxury.  As proposed by Martin Luscher.
  in24 = in24 + 1
  IF (in24.EQ.24) THEN
    in24 = 0
    kount = kount + nskip
    DO isk = 1, nskip
      uni = seeds(j24) - seeds(i24) - carry
      IF (uni.LT.0.) THEN
        uni = uni + 1.0
        carry = twom24
      ELSE
        carry = 0.
      END IF
      seeds(i24) = uni
      i24 = next(i24)
      j24 = next(j24)
    END DO
  END IF
END DO
kount = kount + lenv
IF (kount.GE.igiga) THEN
  mkount = mkount + 1
  kount = kount - igiga
END IF
RETURN

END SUBROUTINE ranlux

!           Subroutine to input and float integer seeds from previous run
SUBROUTINE rluxin
!     the following IF BLOCK added by Phillip Helbig, based on conversation
!     with Fred James; an equivalent correction has been published by James.

IMPLICIT NONE

!     Local variables

INTEGER             :: i, isd

IF (notyet) THEN
  WRITE (6,'(A)') ' Proper results ONLY with initialisation from 25 ',  &
  'integers obtained with RLUXUT'
  notyet = .false.
END IF

twom24 = 1.
DO i = 1, 24
  next(i) = i - 1
  twom24 = twom24 * 0.5
END DO
next(1) = 24
twom12 = twom24 * 4096.
WRITE (6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
WRITE (6,'(5X,5I12)') isdext
DO i = 1, 24
  seeds(i) = REAL(isdext(i)) * twom24
END DO
carry = 0.
IF (isdext(25).LT.0) carry = twom24
isd = ABS(isdext(25))
i24 = MOD(isd,100)
isd = isd / 100
j24 = MOD(isd,100)
isd = isd / 100
in24 = MOD(isd,100)
isd = isd / 100
luxlev = isd
IF (luxlev.LE.maxlev) THEN
  nskip = ndskip(luxlev)
  WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', luxlev
ELSE IF (luxlev.GE.24) THEN
  nskip = luxlev - 24
  WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:', luxlev
ELSE
  nskip = ndskip(maxlev)
  WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ', luxlev
  luxlev = maxlev
END IF
inseed = -1
RETURN

END SUBROUTINE rluxin

!                    Subroutine to ouput seeds as integers
SUBROUTINE rluxut

IMPLICIT NONE

!     Local variables

INTEGER             :: i

DO i = 1, 24
  isdext(i) = INT(seeds(i)*twop12*twop12)
END DO
isdext(25) = i24 + 100 * j24 + 10000 * in24 + 1000000 * luxlev
IF (carry.GT.0.) isdext(25) = -isdext(25)
RETURN

END SUBROUTINE rluxut

!                    Subroutine to output the "convenient" restart point
SUBROUTINE rluxat(lout, inout, k1, k2)

IMPLICIT NONE

INTEGER, INTENT(OUT) :: lout, inout, k1, k2

lout = luxlev
inout = inseed
k1 = kount
k2 = mkount
RETURN

END SUBROUTINE rluxat

!                    Subroutine to initialize from one or three integers
SUBROUTINE rluxgo(lux, ins, k1, k2)

IMPLICIT NONE

INTEGER, INTENT(IN) :: lux, ins, k1, k2

!     Local variables

INTEGER             :: ilx, i, iouter, iseeds(24), isk, k, inner, izip, izip2
REAL                :: uni

IF (lux.LT.0) THEN
  luxlev = lxdflt
ELSE IF (lux.LE.maxlev) THEN
  luxlev = lux
ELSE IF (lux.LT.24.OR.lux.GT.2000) THEN
  luxlev = maxlev
  WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ', lux
ELSE
  luxlev = lux
  DO ilx = 0, maxlev
    IF (lux.EQ.ndskip(ilx)+24) luxlev = ilx
  END DO
END IF
IF (luxlev.LE.maxlev) THEN
  nskip = ndskip(luxlev)
  WRITE (6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', luxlev,  &
                          '     P=', nskip + 24
ELSE
  nskip = luxlev - 24
  WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:', luxlev
END IF
in24 = 0
IF (ins.LT.0) WRITE (6,'(A)') &
              ' Illegal initialization by RLUXGO, negative input seed'
IF (ins.GT.0) THEN
  jseed = ins
  WRITE (6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', jseed, k1, k2
ELSE
  jseed = jsdflt
  WRITE (6,'(A)') ' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
END IF
inseed = jseed
notyet = .false.
twom24 = 1.
DO i = 1, 24
  twom24 = twom24 * 0.5
  k = jseed / 53668
  jseed = 40014 * (jseed-k*53668) - k * 12211
  IF (jseed.LT.0) jseed = jseed + icons
  iseeds(i) = MOD(jseed,itwo24)
END DO
twom12 = twom24 * 4096.
DO i = 1, 24
  seeds(i) = REAL(iseeds(i)) * twom24
  next(i) = i - 1
END DO
next(1) = 24
i24 = 24
j24 = 10
carry = 0.
IF (seeds(24).EQ.0.) carry = twom24
!        If restarting at a break point, skip K1 + IGIGA*K2
!        Note that this is the number of numbers delivered to
!        the user PLUS the number skipped (if luxury .GT. 0).
kount = k1
mkount = k2
IF (k1+k2.NE.0) THEN
  DO iouter = 1, k2 + 1
    inner = igiga
    IF (iouter.EQ.k2+1) inner = k1
    DO isk = 1, inner
      uni = seeds(j24) - seeds(i24) - carry
      IF (uni.LT.0.) THEN
        uni = uni + 1.0
        carry = twom24
      ELSE
        carry = 0.
      END IF
      seeds(i24) = uni
      i24 = next(i24)
      j24 = next(j24)
    END DO
  END DO
!         Get the right value of IN24 by direct calculation
  in24 = MOD(kount,nskip+24)
  IF (mkount.GT.0) THEN
    izip = MOD(igiga, nskip+24)
    izip2 = mkount * izip + in24
    in24 = MOD(izip2, nskip+24)
  END IF
!       Now IN24 had better be between zero and 23 inclusive
  IF (in24.GT.23) THEN
    WRITE (6,'(A/A,3I11,A,I5)') &
               '  Error in RESTARTING with RLUXGO:', '  The values', ins, &
               k1, k2, ' cannot occur at luxury level', luxlev
    in24 = 0
  END IF
END IF
RETURN

END SUBROUTINE rluxgo

END MODULE luxury


SUBROUTINE rk4d_bo1(x,y,h)
! Differential Equation Solver
  USE neo_precision
  USE sizey_bo
  USE neo_rhsbo
!
  IMPLICIT NONE
!
  REAL(kind=dp),               INTENT(inout) ::  x
  REAL(kind=dp),               INTENT(in)    ::  h
  REAL(kind=dp)                              ::  hh,h6,xh
  REAL(kind=dp), DIMENSION(:), INTENT(inout) ::  y
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE   ::  dydx,yt,dyt,dym
  INTEGER                                    ::  i
!
  ALLOCATE(dydx(ndim))
  ALLOCATE(yt(ndim))
  ALLOCATE(dyt(ndim))
  ALLOCATE(dym(ndim))
!
  hh = h / 2
  h6 = h/6
  xh = x+hh
  CALL rhs_bo(x,y,dydx)
  DO i=1,ndim
     yt(i)=y(i)+hh*dydx(i)
  END DO
  CALL rhs_bo(xh,yt,dyt)
  DO i=1,ndim
     yt(i)=y(i)+hh*dyt(i)
  END DO
  CALL rhs_bo(xh,yt,dym)
  DO i=1,ndim
     yt(i)=y(i)+h*dym(i)
     dym(i)=dyt(i)+dym(i)
  END DO
  x=x+h
  CALL rhs_bo(x,yt,dyt)
  DO i=1,ndim
     y(i)=y(i)+h6*(dydx(i)+dyt(i)+2*dym(i))
  END DO

  DEALLOCATE (dydx, yt, dyt, dym)

  RETURN
END SUBROUTINE rk4d_bo1


C******************************************************************************
      SUBROUTINE SORTIN(IBUF,NUM)
C
C	This routine sorts the NUM element integer*4 array, IBUF, in
C	ascending order.
C
C	The sort works by comparing each pair of array elements that are
C	ISPAN elements apart, and placing them in sort with each other.
C       Once this is done, ISPAN is halved, and the process repeated. When
C	the process has been completed for ISPAN = 1, each element is
C	sorted with respect to the following element, hence the entire array
C	must be sorted, by induction.
C
      INTEGER*4 IBUF(NUM)
      LOGICAL MORE_TO_DO
C
      ISPAN = NUM/2
      DO WHILE (ISPAN .GT. 0)
          DO LOCPTR = 1,NUM-ISPAN
              LOC1 = LOCPTR
              MORE_TO_DO = .TRUE.
              DO WHILE (MORE_TO_DO)
                  LOC2 = LOC1 + ISPAN
                  IF(IBUF(LOC1) .GT. IBUF(LOC2)) THEN
                      IHOLD = IBUF(LOC1)
                      IBUF(LOC1) = IBUF(LOC2)
                      IBUF(LOC2) = IHOLD
                      LOC1 = LOC1 - ISPAN
                      IF (LOC1 .LT. 1) MORE_TO_DO = .FALSE.
                  ELSE
                      MORE_TO_DO = .FALSE.
                  END IF
              END DO
          END DO
          ISPAN = ISPAN/2
      END DO
C
      RETURN
      END
C******************************************************************************
      SUBROUTINE SORTR(BUF,NUM)
C
C	This routine sorts the NUM element real*4 array, BUF, in
C	ascending order.
C
C	The sort works by comparing each pair of array elements that are
C	ISPAN elements apart, and placing them in sort with each other.
C       Once this is done, ISPAN is halved, and the process repeated. When
C	the process has been completed for ISPAN = 1, each element is
C	sorted with respect to the following element, hence the entire array
C	must be sorted, by induction.
C
      REAL*4 BUF(NUM)
      LOGICAL MORE_TO_DO
C
      ISPAN = NUM/2
      DO WHILE (ISPAN .GT. 0)
          DO LOCPTR = 1,NUM-ISPAN
              LOC1 = LOCPTR
              MORE_TO_DO = .TRUE.
              DO WHILE (MORE_TO_DO)
                  LOC2 = LOC1 + ISPAN
                  IF(BUF(LOC1) .GT. BUF(LOC2)) THEN
                      HOLD = BUF(LOC1)
                      BUF(LOC1) = BUF(LOC2)
                      BUF(LOC2) = HOLD
                      LOC1 = LOC1 - ISPAN
                      IF (LOC1 .LT. 1) MORE_TO_DO = .FALSE.
                  ELSE
                      MORE_TO_DO = .FALSE.
                  END IF
              END DO
          END DO
          ISPAN = ISPAN/2
      END DO
C
      RETURN
      END
C*************************************************************
      SUBROUTINE INDSRTF(IBUF,INDEX,NUM)
C
C	This routine provides an INDexed SoRT of Fullword data. That is, a
C	NUM element buffer, IBUF, is input.  A NUM element buffer, INDEX, is
C	output, where IBUF(INDEX(I)) is the I'th element of the sorted
C	sequence of IBUF.  The IBUF array itself remains unchanged.
C
C	The sort works by comparing each pair of array elements that are
C	ISPAN elements apart, and placing them in sort with each other.
C       Once this is done, ISPAN is halved, and the process repeated. When
C	the process has been completed for ISPAN = 1, each element is
C	sorted with respect to the following element, hence the entire array
C	must be sorted, by induction.
C
      INTEGER*4 IBUF(NUM),INDEX(NUM)
      LOGICAL MORE_TO_DO
C						initialize the index array
      DO I=1,NUM
          INDEX(I) = I
      END DO
C
      ISPAN = NUM/2
      DO WHILE (ISPAN .GT. 0)
          DO LOCPTR = 1,NUM-ISPAN
              LOC1 = LOCPTR
              MORE_TO_DO = .TRUE.
              DO WHILE (MORE_TO_DO)
                  LOC2 = LOC1 + ISPAN
                  IF(IBUF(INDEX(LOC1)) .GT. IBUF(INDEX(LOC2))) THEN
                      IHOLD = INDEX(LOC1)
                      INDEX(LOC1) = INDEX(LOC2)
                      INDEX(LOC2) = IHOLD
                      LOC1 = LOC1 - ISPAN
                      IF (LOC1 .LT. 1) MORE_TO_DO = .FALSE.
                  ELSE
                      MORE_TO_DO = .FALSE.
                  END IF
              END DO
          END DO
          ISPAN = ISPAN/2
      END DO
C
      RETURN
      END
C*************************************************************
      SUBROUTINE INDSRTR(BUF,INDEX,NUM)
C
C	This routine provides an INDexed SoRT of Real*4 data. That is, a
C	NUM element buffer, BUF, is input.  A NUM element buffer, INDEX, is
C	output, where BUF(INDEX(I)) is the I'th element of the sorted
C	sequence of BUF.  The BUF array itself remains unchanged.
C
C	The sort works by comparing each pair of array elements that are
C	ISPAN elements apart, and placing them in sort with each other.
C       Once this is done, ISPAN is halved, and the process repeated. When
C	the process has been completed for ISPAN = 1, each element is
C	sorted with respect to the following element, hence the entire array
C	must be sorted, by induction.
C
      REAL*4 BUF(NUM)
      INTEGER*4 INDEX(NUM)
      LOGICAL MORE_TO_DO
C						initialize the index array
      DO I=1,NUM
          INDEX(I) = I
      END DO
C
      ISPAN = NUM/2
      DO WHILE (ISPAN .GT. 0)
          DO LOCPTR = 1,NUM-ISPAN
              LOC1 = LOCPTR
              MORE_TO_DO = .TRUE.
              DO WHILE (MORE_TO_DO)
                  LOC2 = LOC1 + ISPAN
                  IF(BUF(INDEX(LOC1)) .GT. BUF(INDEX(LOC2))) THEN
                      IHOLD = INDEX(LOC1)
                      INDEX(LOC1) = INDEX(LOC2)
                      INDEX(LOC2) = IHOLD
                      LOC1 = LOC1 - ISPAN
                      IF (LOC1 .LT. 1) MORE_TO_DO = .FALSE.
                  ELSE
                      MORE_TO_DO = .FALSE.
                  END IF
              END DO
          END DO
          ISPAN = ISPAN/2
      END DO
C
      RETURN
      END


!
!     file hstcsp.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     SUBROUTINE hstcsp(intl, a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc,
!                       bdd, elmbda, f, idimf, pertrb, ierror, w)
!
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n)
! ARGUMENTS
!
! LATEST REVISION        May 2016
!
! PURPOSE                Solves the standard five-point finite
!                        difference approximation on a staggered
!                        grid to the modified helmholtz equation in
!                        spherical coordinates assuming axisymmetry
!                        (no dependence on longitude).
!
!                        the equation is
!
!                           (1/r**2)(d/dr)(r**2(du/dr)) +
!                           1/(r**2*sin(theta))(d/dtheta)
!                           (sin(theta)(du/dtheta)) +
!                           (lambda/(r*sin(theta))**2)u  =  f(theta, r)
!
!                        where theta is colatitude and r is the
!                        radial coordinate. this two-dimensional
!                        modified helmholtz equation results from
!                        the fourier transform of the three-
!                        dimensional poisson equation.
!
!
! USAGE                  call hstcsp(intl, a, b, m, mbdcnd, bda, bdb, c, d, n,
!                                    nbdcnd, bdc, bdd, elmbda, f, idimf,
!                                    pertrb, ierror, w)
!
! ARGUMENTS
!  ON INPUT              intl
!
!                          = 0  on initial entry to hstcsp or if any
!                               of the arguments c, d, n, or nbdcnd
!                               are changed from a previous call
!
!                          = 1  if c, d, n, and nbdcnd are all
!                               unchanged from previous call to hstcsp
!
!                          note:
!                          a call with intl = 0 takes approximately
!                          1.5 times as much time as a call with
!                          intl = 1.  once a call with intl = 0
!                          has been made then subsequent solutions
!                          corresponding to different f, bda, bdb,
!                          bdc, and bdd can be obtained faster with
!                          intl = 1 since initialization is not
!                          repeated.
!
!                        a, b
!                          the range of theta (colatitude),
!                          i.e. a <= theta <= b.  a
!                          must be less than b and a must be
!                          non-negative.  a and b are in radians.
!                          a = 0 corresponds to the north pole and
!                          b = pi corresponds to the south pole.
!
!                          * * *  important  * * *
!
!                          if b is equal to pi, then b must be
!                          computed using the statement
!                              b = pi_mach(dum)
!                          this insures that b in the user's program
!                          is equal to pi in this program, permitting
!                          several tests of the input parameters that
!                          otherwise would not be possible.
!
!                          * * * * * * * * * * * *
!
!                        m
!                          the number of grid points in the interval
!                          (a, b).  the grid points in the theta-
!                          direction are given by
!                            theta(i) = a + (i-0.5)dtheta
!                          for i=1, 2, ..., m where dtheta =(b-a)/m.
!                          m must be greater than 4.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at theta = a and theta = b.
!
!                          = 1  if the solution is specified at
!                               theta = a and theta = b.
!                               (see notes 1, 2 below)
!
!                          = 2  if the solution is specified at
!                               theta = a and the derivative of the
!                               solution with respect to theta is
!                               specified at theta = b
!                               (see notes 1, 2 below).
!
!                          = 3  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = a (see notes 1, 2 below)
!                               and theta = b.
!
!                          = 4  if the derivative of the solution
!                               with respect to theta is specified at
!                               theta = a (see notes 1, 2 below) and
!                               the solution is specified at theta = b.
!
!                          = 5  if the solution is unspecified at
!                               theta = a = 0 and the solution is
!                               specified at theta = b.
!                               (see note 2 below)
!
!                          = 6  if the solution is unspecified at
!                               theta = a = 0 and the derivative of
!                               the solution with respect to theta is
!                               specified at theta = b
!                               (see note 2 below).
!
!                          = 7  if the solution is specified at
!                               theta = a and the solution is
!                               unspecified at theta = b = pi.
!
!                          = 8  if the derivative of the solution
!                               with respect to theta is specified at
!                               theta = a (see note 1 below)
!                               and the solution is unspecified at
!                               theta = b = pi.
!
!                          = 9  if the solution is unspecified at
!                                theta = a = 0 and theta = b = pi.
!
!                          note 1:
!                          if a = 0, do not use mbdcnd = 1, 2, 3, 4, 7
!                          or 8, but instead use mbdcnd = 5, 6, or 9.
!
!                          note 2:
!                          if b = pi, do not use mbdcnd = 1, 2, 3, 4, 5,
!                          or 6, but instead use mbdcnd = 7, 8, or 9.
!
!                          note 3:
!                          when a = 0  and/or b = pi the only
!                          meaningful boundary condition is
!                          du/dtheta = 0.   see d. greenspan,
!                          'numerical analysis of elliptic
!                           boundary value problems, '
!                          harper and row, 1965, chapter 5.)
!
!                        bda
!                          a one-dimensional array of length n that
!                          specifies the boundary values (if any) of
!                          the solution at theta = a.
!
!                          when  mbdcnd = 1, 2, or 7,
!                            bda(j) = u(a, r(j)),   j=1, 2, ..., n.
!
!                          when mbdcnd = 3, 4, or 8,
!                            bda(j) = (d/dtheta)u(a, r(j)), j=1, 2, ..., n.
!
!                          when mbdcnd has any other value, bda is a
!                          dummy variable.
!
!                        bdb
!                          a one-dimensional array of length n that
!                          specifies the boundary values of the
!                          solution at theta = b.
!
!                          when mbdcnd = 1, 4, or 5,
!                            bdb(j) = u(b, r(j)),     j=1, 2, ..., n.
!
!                          when mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dtheta)u(b, r(j)), j=1, 2, ..., n.
!
!                          when mbdcnd has any other value, bdb is
!                          a dummy variable.
!
!                        c, d
!                          the range of r , i.e. c <= r <= d.
!                          c must be less than d and non-negative.
!
!                        n
!                          the number of unknowns in the interval
!                          (c, d).  the unknowns in the r-direction
!                          are given by r(j) = c + (j-0.5)dr,
!                          j=1, 2, ..., n, where dr = (d-c)/n.
!                          n must be greater than 4.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at r = c and r = d.
!
!
!                          = 1  if the solution is specified at
!                               r = c and r = d.
!
!                          = 2  if the solution is specified at
!                               r = c and the derivative of the
!                               solution with respect to r is
!                               specified at r = d. (see note 1 below)
!
!                          = 3  if the derivative of the solution
!                               with respect to r is specified at
!                               r = c and r = d.
!
!                          = 4  if the derivative of the solution
!                               with respect to r is
!                               specified at r = c and the solution
!                               is specified at r = d.
!
!                          = 5  if the solution is unspecified at
!                               r = c = 0 (see note 2 below) and the
!                               solution is specified at r = d.
!
!                          = 6  if the solution is unspecified at
!                               r = c = 0 (see note 2 below)
!                               and the derivative of the solution
!                               with respect to r is specified at
!                               r = d.
!
!                          note 1:
!                          if c = 0 and mbdcnd = 3, 6, 8 or 9, the
!                          system of equations to be solved is
!                          singular.  the unique solution is
!                          determined by extrapolation to the
!                          specification of u(theta(1), c).
!                          but in these cases the right side of the
!                          system will be perturbed by the constant
!                          pertrb.
!
!                          note 2:
!                          nbdcnd = 5 or 6 cannot be used with
!                          mbdcnd =1, 2, 4, 5, or 7
!                          (the former indicates that the solution is
!                          unspecified at r = 0; the latter indicates
!                          solution is specified).
!                          use instead nbdcnd = 1 or 2.
!
!                        bdc
!                          a one dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at r = c.  when nbdcnd = 1 or 2,
!                            bdc(i) = u(theta(i), c),    i=1, 2, ..., m.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dr)u(theta(i), c), i=1, 2, ..., m.
!
!                          when nbdcnd has any other value, bdc is
!                          a dummy variable.
!
!                        bdd
!                          a one-dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at r = d.  when nbdcnd = 1 or 4,
!                            bdd(i) = u(theta(i), d) ,    i=1, 2, ..., m.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) = (d/dr)u(theta(i), d), i=1, 2, ..., m.
!
!                          when nbdcnd has any other value, bdd is
!                          a dummy variable.
!
!                        elmbda
!                          the constant lambda in the modified
!                          helmholtz equation.  if lambda is greater
!                          than 0, a solution may not exist.
!                          however, hstcsp will attempt to find a
!                          solution.
!
!                        f
!                          a two-dimensional array that specifies the
!                          values of the right side of the modified
!                          helmholtz equation.  for i=1, 2, ..., m and
!                          j=1, 2, ..., n
!
!                                f(i, j) = f(theta(i), r(j)) .
!
!                          f must be dimensioned at least m x n.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hstcsp.  this parameter is used to specify
!                          the variable dimension of f.
!                          idimf must be at least m.
!
!                        w
!                          A derived type(FishpackWorkspace) variable
!                          that must be declared by the user.  the first
!                          two declarative statements in the user program
!                          calling hstcsp must be:
!
!                               use type_fishpackworkspace
!                               type(FishpackWorkspace) :: w
!
!                          the first statement makes the fishpack module
!                          defined in the file "type_fishpackworkspace.f90" available to the
!                          user program calling hstcsp.  the second statement
!                          declares a derived type variable (defined in
!                          the module "type_fishpackworkspace.f90") which is used internally
!                          in blktri to dynamically allocate real and complex
!                          workspace used in solution.  an error flag
!                          (ierror = 20) is set if the required workspace
!                          allocation fails (for example if n, m are too large)
!                          real and complex values are set in the components
!                          of w on a initial (iflg=0) call to hstcsp.  these
!                          must be preserved on non-initial calls (intl=1)
!                          to hstcsp.  this eliminates redundant calculations
!                          and saves compute time.
!
!               ****       IMPORTANT!  the user program calling hstcsp should
!                          include the statement:
!
!                               call workspace%destroy()
!
!                          after the final approximation is generated by
!                          hstcsp.  the will deallocate the real and complex
!                          workspace of w.  failure to include this statement
!                          could result in serious memory leakage.
!
!
!
! ON OUTPUT              f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (theta(i), r(j)) for i=1, 2, .., m, j=1, 2, ..., n.
!
!                        pertrb
!                          if a combination of periodic, derivative,
!                          or unspecified boundary conditions is
!                          specified for a poisson equation
!                          (lambda = 0), a solution may not exist.
!                          pertrb is a constant, calculated and
!                          subtracted from f, which ensures that a
!                          solution exists.  hstcsp then computes this
!                          solution, which is a least squares solution
!                          to the original approximation.
!                          this solution plus any constant is also
!                          a solution; hence, the solution is not
!                          unique.  the value of pertrb should be
!                          small compared to the right side f.
!                          otherwise, a solution is obtained to an
!                          essentially different problem.
!                          this comparison should always be made to
!                          insure that a meaningful solution has been
!                          obtained.
!
!                        ierror
!                          an error flag that indicates invalid input
!                          parameters. except for numbers 0 and 10,
!                          a solution is not attempted.
!
!                          =  0  no error
!
!                          =  1  a < 0 or b > pi
!
!                          =  2  a >= b
!
!                          =  3  mbdcnd < 1 or mbdcnd > 9
!
!                          =  4  c < 0
!
!                          =  5  c >= d
!
!                          =  6  nbdcnd < 1 or nbdcnd > 6
!
!                          =  7  n < 5
!
!                          =  8  nbdcnd = 5 or 6 and
!                                mbdcnd = 1, 2, 4, 5, or 7
!
!                          =  9  c > 0 and 5 <= nbdcnd
!
!                          = 10  elmbda > 0
!
!                          = 11  idimf < m
!
!                          = 12  m < 5
!
!                          = 13  a = 0 and mbdcnd =1, 2, 3, 4, 7 or 8
!
!                          = 14  b = pi and mbdcnd <= 6
!
!                          = 15  a > 0 and mbdcnd = 5, 6, or 9
!
!                          = 16  b < pi and 7 <= mbdcnd
!
!                          = 17  lambda /= 0 and 5 <= nbdcnd
!
!                          since this is the only means of indicating
!                          a possibly incorrect call to hstcsp,
!                          the user should test ierror after the call.
!
!                        = 20 If the dynamic allocation of real and
!                             complex workspace in the derived type
!                             (FishpackWorkspace) variable w fails (e.g.,
!                             if n, m are too large for the platform used)
!
!                        w
!                             The derived type(FishpackWorkspace) variable w
!                             contains real and complex values that must not
!                             be destroyed if hstcsp is called again with
!                             iflg=1.
!
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED LIBRARY       type_FishpackWorkspace.f90, blktri.f90
! FILES
!
! HISTORY                * Written by Roland Sweet at NCAR in 1977.
!                          released on NCAR's public software libraries
!                          in January 1980.
!                        * Revised by John Adams in June
!                          2004 using Fortan 90 dynamically allocated work
!                          space and derived data types to eliminate mixed
!                          mode conflicts in the earlier versions.
!
! STANDARD               Fortran 2008
!
! ALGORITHM              This subroutine defines the finite-difference
!                        equations, incorporates boundary data, adjusts
!                        the right side when the system is singular
!                        and calls blktri which solves the linear
!                        system of equations.
!
!
! TIMING                 For large m and n, the operation count is
!                        roughly proportional to
!
!                        m*n*log2(n).
!
!                        The timing also depends on input parameter intl.
!
! ACCURACY               The solution process employed results in
!                        a loss of no more than four significant
!                        digits for n and m as large as 64.
!                        more detailed information about accuracy
!                        can be found in the documentation for
!                        subroutine blktri which is the routine
!                        solves the finite difference equations.
!
! REFERENCES             P.N. Swarztrauber, "A direct method for
!                        the discrete solution of separable elliptic
!                        equations", SIAM J. Numer. Anal. 11(1974),
!                        pp. 1136-1150.
!
!                        U. Schumann and R. Sweet, "A direct method for
!                        the solution of poisson's equation with neumann
!                        boundary conditions on a staggered grid of
!                        arbitrary size, " J. Comp. Phys. 20(1976),
!                        pp. 171-182.
!
submodule(staggered_helmholtz_solvers) staggered_axisymmetric_spherical_solver

!---------------------------------------------------------------
! Parameters confined to the submodule
!---------------------------------------------------------------
integer(ip), parameter :: IIWK = 8_ip ! Size of workspace indices
!---------------------------------------------------------------

contains

    module subroutine hstcsp(intl, a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, &
        bdc, bdd, elmbda, f, idimf, pertrb, ierror, workspace)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(inout) :: intl
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        class(FishpackWorkspace), intent(inout) :: workspace
        !-----------------------------------------------

        ! Check for invalid input parameters
        call hstcsp_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, elmbda, idimf, ierror)

        if (ierror /= 0) return

        ! Initialize workspace on first call
        if (intl == 0) call hstcsp_initialize_workspace(n, m, workspace)

        ! Solve system
        associate( &
            iwam => workspace%workspace_indices(1), &
            iwbm => workspace%workspace_indices(2), &
            iwcm => workspace%workspace_indices(3), &
            iwan => workspace%workspace_indices(4), &
            iwbn => workspace%workspace_indices(5), &
            iwcn => workspace%workspace_indices(6), &
            iwsnth => workspace%workspace_indices(7), &
            iwrsq => workspace%workspace_indices(8), &
            rew => workspace%real_workspace, &
            cxw => workspace%complex_workspace &
            )
            associate( &
                am => rew(iwam:), &
                bm => rew(iwbm:), &
                cm => rew(iwcm:), &
                an => rew(iwan:), &
                bn => rew(iwbn:), &
                cn => rew(iwcn:), &
                snth => rew(iwsnth:), &
                rsq => rew(iwrsq:), &
                w => rew, &
                wc => cxw &
                )
                call hstcsp_lower_routine(intl, a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd, &
                    elmbda, f, idimf, pertrb, ierror, am, bm, cm, an, bn, &
                    cn, snth, rsq, w, wc)
            end associate
        end associate

    end subroutine hstcsp

    subroutine hstcsp_initialize_workspace(n, m, workspace)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: m
        class(FishpackWorkspace), intent(out) :: workspace
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        integer(ip) :: irwk, icwk, indx(IIWK)
        !-----------------------------------------------

        ! Compute blktri requirements in irwk, icwk
        call workspace%compute_blktri_workspace_lengths(n, m, irwk, icwk)

        ! Compute indices
        associate( &
            iw1 => indx(1), &
            iwbm => indx(2), &
            iwcm => indx(3), &
            iwan => indx(4), &
            iwbn => indx(5), &
            iwcn => indx(6), &
            iwsnth => indx(7), &
            iwrsq => indx(8) &
            )

            ! Set workspace indices
            iw1 = irwk + 1
            iwbm = iw1 + m
            iwcm = iwbm + m
            iwan = iwcm + m
            iwbn = iwan + n
            iwcn = iwbn + n
            iwsnth = iwcn + n
            iwrsq = iwsnth + m

            ! Adjust real and complex workspace arrays for hstcsp
            irwk = iwrsq + n
            icwk = icwk + 3 * (m + 1)
        end associate

        ! Allocate required memory for workspace arrays
        call workspace%create(irwk, icwk, IIWK)

        ! Copy indices
        workspace%workspace_indices = indx

    end subroutine hstcsp_initialize_workspace

    pure subroutine hstcsp_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, elmbda, idimf, ierror)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        !-----------------------------------------------

        if (a < ZERO .or. b > PI) then
            ierror = 1
            return
        else if (a >= b) then
            ierror = 2
            return
        else if (mbdcnd < 1 .or. mbdcnd > 9) then
            ierror = 3
            return
        else if (c < ZERO) then
            ierror = 4
            return
        else if (c >= d) then
            ierror = 5
            return
        else if (nbdcnd < 1 .or. nbdcnd > 6) then
            ierror = 6
            return
        else if (n < 5) then
            ierror = 7
            return
        else if (nbdcnd == 5 .or. nbdcnd == 6) then
            select case (mbdcnd)
                case (1:2, 4:5, 7)
                    ierror = 8
                    return
            end select
        else if (c > ZERO .and. 5 <= nbdcnd) then
            ierror = 9
            return
        else if (idimf < m) then
            ierror = 11
            return
        else if (m < 5) then
            ierror = 12
            return
        else if (a == ZERO .and. mbdcnd /= 5.and. mbdcnd /= 6.and. mbdcnd /= 9) then
            ierror = 13
            return
        else if (b == PI .and. mbdcnd <= 6) then
            ierror = 14
            return
        else if (a > ZERO) then
            select case (mbdcnd)
                case (5:6, 9)
                    ierror=15
                    return
            end select
        else if (b < PI .and. 7 <= mbdcnd) then
            ierror = 16
            return
        else if (elmbda /= ZERO .and. 5 <= nbdcnd) then
            ierror = 17
            return
        else
            ierror = 0
        end if

    end subroutine hstcsp_check_input_arguments

    subroutine hstcsp_lower_routine(intl, a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, &
        bdc, bdd, elmbda, f, idimf, pertrb, ierror, am, bm, cm, an, bn, &
        cn, snth, rsq, w, wc)
        !-----------------------------------------------
        ! Dummy arguments
        !-----------------------------------------------
        integer(ip), intent(in)     :: intl
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        real(wp),    intent(out) :: am(:)
        real(wp),    intent(out) :: bm(:)
        real(wp),    intent(out) :: cm(:)
        real(wp),    intent(out) :: an(:)
        real(wp),    intent(out) :: bn(:)
        real(wp),    intent(out) :: cn(:)
        real(wp),    intent(out) :: snth(:)
        real(wp),    intent(out) :: rsq(:)
        real(wp),    intent(out) :: w(:)
        complex(wp), intent(out) :: wc(:)
        !-----------------------------------------------
        ! Local variables
        !-----------------------------------------------
        integer(ip)     :: i, j, isw, nb
        real(wp)        :: dth, dthsq, dr, x, y, a2, a1, a3
        type(GeneralizedCyclicReductionUtility) :: util
        !-----------------------------------------------

        dth = (b - a)/m
        dthsq = dth**2

        do i = 1, m
            snth(i) = sin(a + (real(i, kind=wp) - HALF)*dth)
        end do

        dr = (d - c)/n

        do j = 1, n
            rsq(j) = (c + (real(j, kind=wp) - HALF)*dr)**2
        end do
        !
        !     multiply right side by r(j)**2
        !
        do j = 1, n
            x = rsq(j)
            f(:m, j) = x*f(:m, j)
        end do
        !
        !      define coefficients am, bm, cm
        !
        x = ONE/(TWO*cos(dth/2))
        am(2:m) = (snth(:m-1)+snth(2:m))*x
        cm(:m-1) = am(2:m)
        am(1) = sin(a)
        cm(m) = sin(b)
        do i = 1, m
            x = ONE/snth(i)
            y = x/dthsq
            am(i) = am(i)*y
            cm(i) = cm(i)*y
            bm(i) = elmbda*(x**2) - am(i) - cm(i)
        end do
        !
        ! Define coefficients an, bn, cn
        !
        x = c/dr
        do j = 1, n
            an(j) = (x + real(j - 1, kind=wp))**2
            cn(j) = (x + real(j, kind=wp))**2
            bn(j) = -(an(j)+cn(j))
        end do
        isw = 1
        nb = nbdcnd

        if (c == ZERO .and. nb == 2) nb = 6
        !
        ! Enter data on theta boundaries
        !
        select case (mbdcnd)
            case (1:2, 7)
                bm(1) = bm(1) - am(1)
                x = TWO*am(1)
                f(1, :n) = f(1, :n) - x*bda
            case (3:4, 8)
                bm(1) = bm(1) + am(1)
                x = dth*am(1)
                f(1, :n) = f(1, :n) + x*bda
        end select

        select case (mbdcnd)
            case (1, 4:5)
                bm(m) = bm(m) - cm(m)
                x = TWO*cm(m)
                f(m, :n) = f(m, :n) - x*bdb
            case (2:3, 6)
                bm(m) = bm(m) + cm(m)
                x = dth*cm(m)
                f(m, :n) = f(m, :n) - x*bdb
        end select

        select case (nb)
            case (1:2)
                bn(1) = bn(1) - an(1)
                x = TWO*an(1)
                f(:m, 1) = f(:m, 1) - x*bdc
            case (3:4)
                bn(1) = bn(1) + an(1)
                x = dr*an(1)
                f(:m, 1) = f(:m, 1) + x*bdc
        end select

        select case (nb)
            case (1, 4:5)
                bn(n) = bn(n) - cn(n)
                x = TWO*cn(n)
                f(:m, n) = f(:m, n) - x*bdd
            case (2:3, 6)
                bn(n) = bn(n) + cn(n)
                x = dr*cn(n)
                f(:m, n) = f(:m, n) - x*bdd
        end select

        pertrb = ZERO

        case_construct: select case (mbdcnd)
            case (1:2, 4:5, 7)
                exit case_construct
            case (3, 6, 8:9)
                select case (nb)
                    case (1:2, 4:5)
                        exit case_construct
                    case (3, 6)
                        if (elmbda >= ZERO) then
                            if (elmbda /= ZERO) then
                                ierror = 10
                            else
                                isw = 2
                                do i = 1, m
                                    x = ZERO
                                    x = sum(f(i, :n))
                                    pertrb = pertrb + x*snth(i)
                                end do
                                x = ZERO
                                x = sum(rsq(:n))
                                pertrb = TWO*(pertrb*sin(dth/2))/(x*(cos(a) - cos(b)))
                                do j = 1, n
                                    x = rsq(j)*pertrb
                                    f(:m, j) = f(:m, j) - x
                                end do
                            end if
                        end if
                end select
        end select case_construct

        a2 = sum(f(:m, 1))/rsq(1)

        if (intl == 0) then
            !
            ! Initialize blktri
            !
            call util%blktrii(0, 1, n, an, bn, cn, 1, m, am, bm, cm, idimf, f, ierror, w, wc)

            ! Check error flag
            if (ierror /= 0) then
                error stop 'fishpack library: blktrii initialization call failed in hstcsp_lower_routine'
            end if

        end if

        call util%blktrii(1, 1, n, an, bn, cn, 1, m, am, bm, cm, idimf, f, ierror, w, wc)

        ! Check error flag
        if (ierror /= 0) then
            error stop 'fishpack library: blktrii call failed in hstcsp_lower_routine'
        end if

        if (.not.(isw /=2 .or. c /= ZERO .or. nbdcnd /= 2)) then
            a3 = ZERO
            a1 = dot_product(snth(:m), f(:m, 1))
            a3 = sum(snth(:m))
            a1 = a1 + rsq(1)*a2/2

            if (mbdcnd == 3) a1=a1+(sin(b)*bdb(1)-sin(a)*bda(1))/(TWO*(b-a))

            a1 = a1/a3
            a1 = bdc(1) - a1
            f(:m, :n) = f(:m, :n) + a1
        end if

    end subroutine hstcsp_lower_routine

end submodule staggered_axisymmetric_spherical_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
!-----------------------------------------------------------------------


*DECK DSVDC
      SUBROUTINE DSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB,
     +   INFO)
C***BEGIN PROLOGUE  DSVDC
C***PURPOSE  Perform the singular value decomposition of a rectangular
C            matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D6
C***TYPE      DOUBLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX,
C             SINGULAR VALUE DECOMPOSITION
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     DSVDC is a subroutine to reduce a double precision NxP matrix X
C     by orthogonal transformations U and V to diagonal form.  The
C     diagonal elements S(I) are the singular values of X.  The
C     columns of U are the corresponding left singular vectors,
C     and the columns of V the right singular vectors.
C
C     On Entry
C
C         X         DOUBLE PRECISION(LDX,P), where LDX .GE. N.
C                   X contains the matrix whose singular value
C                   decomposition is to be computed.  X is
C                   destroyed by DSVDC.
C
C         LDX       INTEGER.
C                   LDX is the leading dimension of the array X.
C
C         N         INTEGER.
C                   N is the number of rows of the matrix X.
C
C         P         INTEGER.
C                   P is the number of columns of the matrix X.
C
C         LDU       INTEGER.
C                   LDU is the leading dimension of the array U.
C                   (See below).
C
C         LDV       INTEGER.
C                   LDV is the leading dimension of the array V.
C                   (See below).
C
C         WORK      DOUBLE PRECISION(N).
C                   WORK is a scratch array.
C
C         JOB       INTEGER.
C                   JOB controls the computation of the singular
C                   vectors.  It has the decimal expansion AB
C                   with the following meaning
C
C                        A .EQ. 0    do not compute the left singular
C                                  vectors.
C                        A .EQ. 1    return the N left singular vectors
C                                  in U.
C                        A .GE. 2    return the first MIN(N,P) singular
C                                  vectors in U.
C                        B .EQ. 0    do not compute the right singular
C                                  vectors.
C                        B .EQ. 1    return the right singular vectors
C                                  in V.
C
C     On Return
C
C         S         DOUBLE PRECISION(MM), where MM=MIN(N+1,P).
C                   The first MIN(N,P) entries of S contain the
C                   singular values of X arranged in descending
C                   order of magnitude.
C
C         E         DOUBLE PRECISION(P).
C                   E ordinarily contains zeros.  However see the
C                   discussion of INFO for exceptions.
C
C         U         DOUBLE PRECISION(LDU,K), where LDU .GE. N.
C                   If JOBA .EQ. 1, then K .EQ. N.
C                   If JOBA .GE. 2, then K .EQ. MIN(N,P).
C                   U contains the matrix of right singular vectors.
C                   U is not referenced if JOBA .EQ. 0.  If N .LE. P
C                   or if JOBA .EQ. 2, then U may be identified with X
C                   in the subroutine call.
C
C         V         DOUBLE PRECISION(LDV,P), where LDV .GE. P.
C                   V contains the matrix of right singular vectors.
C                   V is not referenced if JOB .EQ. 0.  If P .LE. N,
C                   then V may be identified with X in the
C                   subroutine call.
C
C         INFO      INTEGER.
C                   The singular values (and their corresponding
C                   singular vectors) S(INFO+1),S(INFO+2),...,S(M)
C                   are correct (here M=MIN(N,P)).  Thus if
C                   INFO .EQ. 0, all the singular values and their
C                   vectors are correct.  In any event, the matrix
C                   B = TRANS(U)*X*V is the bidiagonal matrix
C                   with the elements of S on its diagonal and the
C                   elements of E on its super-diagonal (TRANS(U)
C                   is the transpose of U).  Thus the singular
C                   values of X and B are the same.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT, DNRM2, DROT, DROTG, DSCAL, DSWAP
C***REVISION HISTORY  (YYMMDD)
C   790319  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSVDC
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     1        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN,
     1                 SMM1,T1,TEST,ZTEST
      LOGICAL WANTU,WANTV
C***FIRST EXECUTABLE STATEMENT  DSVDC
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN(N-1,P)
      NRT = MAX(0,MIN(P-2,N))
      LU = MAX(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = DNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0D0) GO TO 10
               IF (X(L,L) .NE. 0.0D0) S(L) = SIGN(S(L),X(L,L))
               CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0D0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = DNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0D0) GO TO 80
               IF (E(LP1) .NE. 0.0D0) E(L) = SIGN(E(L),E(LP1))
               CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1)
               E(LP1) = 1.0D0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0D0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0D0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0D0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0D0
  180       CONTINUE
            U(J,J) = 1.0D0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0D0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL DSCAL(N-L+1,-1.0D0,U(L,L),1)
               U(L,L) = 1.0D0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0D0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0D0
  260          CONTINUE
               U(L,L) = 1.0D0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0D0) GO TO 320
               DO 310 J = LP1, P
                  T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0D0
  330       CONTINUE
            V(L,L) = 1.0D0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
            IF (L .EQ. 0) GO TO 400
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0D0
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0D0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0D0
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0D0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0D0
            DO 530 K = L, M
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),
     1                    ABS(S(L)),ABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0
            C = (SM*EMM1)**2
            SHIFT = 0.0D0
            IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0D0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL DROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL DROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     1            CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0D0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     1            CALL DSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     1            CALL DSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END


      PROGRAM min_cost
      IMPLICIT NONE

      INTEGER (KIND=8),PARAMETER::n_line=441
      REAL (KIND=8),PARAMETER::cost0=2.
      INTEGER (KIND=8):: i
      REAL    (KIND=8):: Naa_av,Nbb_av,Nab_av
      REAL    (KIND=8):: Z,Jbb_av,Jab_av,Jbb2_av,Jab2_av,delJbb,delJab

      REAL (KIND=8),DIMENSION(n_line) :: Jbb,Jab,FNaa,FNbb,FNab,cost

!!!=======================================================================================
!!!=======================================================================================
      OPEN(unit=12,file='average_thermal.dat')
      OPEN(unit=13,file='average_thermal_min.dat')
      OPEN(unit=14,file='average_thermal_plot.dat')
      OPEN(unit=15,file='result_final.dat')
!!!=======================================================================================
!!! Partition function:
      Z=0.
      DO i=1,n_line
            READ(12,*)Jbb(i),Jab(i),Naa_av,Nbb_av,Nab_av,FNaa(i),FNbb(i),FNab(i),cost(i)

            Z=Z+exp(-cost(i))

            IF (cost(i)<cost0) THEN
                  WRITE(13,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)
                  WRITE(*,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)
            END IF

            WRITE(14,'(F8.4,3X,F8.4,4X,F16.4)') Jbb(i),Jab(i),cost(i)

      END DO

!!!=======================================================================================
!!! Expectation value by using normal distribution
      Jbb_av=0. ;  Jab_av=0. ; Jbb2_av=0. ;  Jab2_av=0.
      DO i=1,n_line
                  Jbb_av=Jbb_av+Jbb(i)*exp(-cost(i))
                  Jab_av=Jab_av+Jab(i)*exp(-cost(i))

                  Jbb2_av=Jbb2_av+Jbb(i)*Jbb(i)*exp(-cost(i))
                  Jab2_av=Jab2_av+Jab(i)*Jab(i)*exp(-cost(i))

      END DO

      Jbb_av=Jbb_av/Z ; Jab_av=Jab_av/Z
      Jbb2_av=Jbb2_av/Z ; Jab2_av=Jab2_av/Z

      delJbb=sqrt(Jbb2_av-Jbb_av**2.)
      delJab=sqrt(Jab2_av-Jab_av**2.)

      WRITE(13,*)'Jbb_av:',Jbb_av,'Jab_av:',Jab_av,'delJbb:',delJbb,'delJab:',delJab
      WRITE(*,*)'Jbb_av:',Jbb_av,'delJbb:',delJbb,'Jab_av:',Jab_av,'delJab:',delJab

      WRITE(15,'(4F9.3,4X,4F9.3)')Jbb_av,delJbb,Jbb_av-delJbb,Jbb_av+delJbb,Jab_av,delJab,Jab_av-delJab,Jab_av+delJab
      WRITE(*,'(4F9.3,4X,4F9.3)')Jbb_av,delJbb,Jbb_av-delJbb,Jbb_av+delJbb,Jab_av,delJab,Jab_av-delJab,Jab_av+delJab

      CLOSE(12)
      CLOSE(13)
      CLOSE(14)
      CLOSE(15)

!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      END PROGRAM min_cost


*DECK DHFTI
      SUBROUTINE DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H,
     +   G, IP)
C***BEGIN PROLOGUE  DHFTI
C***PURPOSE  Solve a least squares problem for banded matrices using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      DOUBLE PRECISION (HFTI-S, DHFTI-D)
C***KEYWORDS  CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N)
C
C     This subroutine solves a linear least squares problem or a set of
C     linear least squares problems having the same matrix but different
C     right-side vectors.  The problem data consists of an M by N matrix
C     A, an M by NB matrix B, and an absolute tolerance parameter TAU
C     whose usage is described below.  The NB column vectors of B
C     represent right-side vectors for NB distinct linear least squares
C     problems.
C
C     This set of problems can also be written as the matrix least
C     squares problem
C
C                       AX = B,
C
C     where X is the N by NB solution matrix.
C
C     Note that if B is the M by M identity matrix, then X will be the
C     pseudo-inverse of A.
C
C     This subroutine first transforms the augmented matrix (A B) to a
C     matrix (R C) using premultiplying Householder transformations with
C     column interchanges.  All subdiagonal elements in the matrix R are
C     zero and its diagonal elements satisfy
C
C                       ABS(R(I,I)).GE.ABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, where
C
C                       L = MIN(M,N).
C
C     The subroutine will compute an integer, KRANK, equal to the number
C     of diagonal terms of R that exceed TAU in magnitude. Then a
C     solution of minimum Euclidean length is computed using the first
C     KRANK rows of (R C).
C
C     To be specific we suggest that the user consider an easily
C     computable matrix norm, such as, the maximum of all column sums of
C     magnitudes.
C
C     Now if the relative uncertainty of B is EPS, (norm of uncertainty/
C     norm of B), it is suggested that TAU be set approximately equal to
C     EPS*(norm of A).
C
C     The user must dimension all arrays appearing in the call list..
C     A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N).  This
C     permits the solution of a range of problems in the same array
C     space.
C
C     The entire set of parameters for DHFTI are
C
C     INPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     A(*,*),MDA,M,N    The array A(*,*) initially contains the M by N
C                       matrix A of the least squares problem AX = B.
C                       The first dimensioning parameter of the array
C                       A(*,*) is MDA, which must satisfy MDA.GE.M
C                       Either M.GE.N or M.LT.N is permitted.  There
C                       is no restriction on the rank of A.  The
C                       condition MDA.LT.M is considered an error.
C
C     B(*),MDB,NB       If NB = 0 the subroutine will perform the
C                       orthogonal decomposition but will make no
C                       references to the array B(*).  If NB.GT.0
C                       the array B(*) must initially contain the M by
C                       NB matrix B of the least squares problem AX =
C                       B.  If NB.GE.2 the array B(*) must be doubly
C                       subscripted with first dimensioning parameter
C                       MDB.GE.MAX(M,N).  If NB = 1 the array B(*) may
C                       be either doubly or singly subscripted.  In
C                       the latter case the value of MDB is arbitrary
C                       but it should be set to some valid integer
C                       value such as MDB = M.
C
C                       The condition of NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       is considered an error.
C
C     TAU               Absolute tolerance parameter provided by user
C                       for pseudorank determination.
C
C     H(*),G(*),IP(*)   Arrays of working space used by DHFTI.
C
C     OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION
C
C     A(*,*)            The contents of the array A(*,*) will be
C                       modified by the subroutine. These contents
C                       are not generally required by the user.
C
C     B(*)              On return the array B(*) will contain the N by
C                       NB solution matrix X.
C
C     KRANK             Set by the subroutine to indicate the
C                       pseudorank of A.
C
C     RNORM(*)          On return, RNORM(J) will contain the Euclidean
C                       norm of the residual vector for the problem
C                       defined by the J-th column vector of the array
C                       B(*,*) for J = 1,...,NB.
C
C     H(*),G(*)         On return these arrays respectively contain
C                       elements of the pre- and post-multiplying
C                       Householder transformations used to compute
C                       the minimum Euclidean length solution.
C
C     IP(*)             Array in which the subroutine records indices
C                       describing the permutation of column vectors.
C                       The contents of arrays H(*),G(*) and IP(*)
C                       are not generally required by the user.
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 14.
C***ROUTINES CALLED  D1MACH, DH12, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   901005  Replace usage of DDIFF with usage of D1MACH.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DHFTI
      INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L,
     *     LDIAG, LMAX, M, MDA, MDB, N, NB, NERR
      DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR,
     *     G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP
      DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*)
      SAVE RELEPS
      DATA RELEPS /0.D0/
C     BEGIN BLOCK PERMITTING ...EXITS TO 360
C***FIRST EXECUTABLE STATEMENT  DHFTI
         IF (RELEPS.EQ.0.D0) RELEPS = D1MACH(4)
         SZERO = 0.0D0
         DZERO = 0.0D0
         FACTOR = 0.001D0
C
         K = 0
         LDIAG = MIN(M,N)
         IF (LDIAG .LE. 0) GO TO 350
C           BEGIN BLOCK PERMITTING ...EXITS TO 130
C              BEGIN BLOCK PERMITTING ...EXITS TO 120
                  IF (MDA .GE. M) GO TO 10
                     NERR = 1
                     IOPT = 2
                     CALL XERMSG ('SLATEC', 'DHFTI',
     +                  'MDA.LT.M, PROBABLE ERROR.',
     +                  NERR, IOPT)
C     ...............EXIT
                     GO TO 360
   10             CONTINUE
C
                  IF (NB .LE. 1 .OR. MAX(M,N) .LE. MDB) GO TO 20
                     NERR = 2
                     IOPT = 2
                     CALL XERMSG ('SLATEC', 'DHFTI',
     +                  'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.',
     +                  NERR, IOPT)
C     ...............EXIT
                     GO TO 360
   20             CONTINUE
C
                  DO 100 J = 1, LDIAG
C                    BEGIN BLOCK PERMITTING ...EXITS TO 70
                        IF (J .EQ. 1) GO TO 40
C
C                           UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C                          ..
                           LMAX = J
                           DO 30 L = J, N
                              H(L) = H(L) - A(J-1,L)**2
                              IF (H(L) .GT. H(LMAX)) LMAX = L
   30                      CONTINUE
C                    ......EXIT
                           IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 70
   40                   CONTINUE
C
C                        COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C                       ..
                        LMAX = J
                        DO 60 L = J, N
                           H(L) = 0.0D0
                           DO 50 I = J, M
                              H(L) = H(L) + A(I,L)**2
   50                      CONTINUE
                           IF (H(L) .GT. H(LMAX)) LMAX = L
   60                   CONTINUE
                        HMAX = H(LMAX)
   70                CONTINUE
C                    ..
C                     LMAX HAS BEEN DETERMINED
C
C                     DO COLUMN INTERCHANGES IF NEEDED.
C                    ..
                     IP(J) = LMAX
                     IF (IP(J) .EQ. J) GO TO 90
                        DO 80 I = 1, M
                           TMP = A(I,J)
                           A(I,J) = A(I,LMAX)
                           A(I,LMAX) = TMP
   80                   CONTINUE
                        H(LMAX) = H(J)
   90                CONTINUE
C
C                     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A
C                     AND B.
C                    ..
                     CALL DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,
     *                         N-J)
                     CALL DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
  100             CONTINUE
C
C                  DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE,
C                  TAU.
C                 ..
                  DO 110 J = 1, LDIAG
C              ......EXIT
                     IF (ABS(A(J,J)) .LE. TAU) GO TO 120
  110             CONTINUE
                  K = LDIAG
C           ......EXIT
                  GO TO 130
  120          CONTINUE
               K = J - 1
  130       CONTINUE
            KP1 = K + 1
C
C           COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
            IF (NB .LT. 1) GO TO 170
            DO 160 JB = 1, NB
               TMP = SZERO
               IF (M .LT. KP1) GO TO 150
               DO 140 I = KP1, M
                  TMP = TMP + B(I,JB)**2
  140          CONTINUE
  150          CONTINUE
               RNORM(JB) = SQRT(TMP)
  160       CONTINUE
  170       CONTINUE
C           SPECIAL FOR PSEUDORANK = 0
            IF (K .GT. 0) GO TO 210
               IF (NB .LT. 1) GO TO 200
               DO 190 JB = 1, NB
                  DO 180 I = 1, N
                     B(I,JB) = SZERO
  180             CONTINUE
  190          CONTINUE
  200          CONTINUE
            GO TO 340
  210       CONTINUE
C
C               IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C               DECOMPOSITION OF FIRST K ROWS.
C              ..
               IF (K .EQ. N) GO TO 230
                  DO 220 II = 1, K
                     I = KP1 - II
                     CALL DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  220             CONTINUE
  230          CONTINUE
C
C
               IF (NB .LT. 1) GO TO 330
               DO 320 JB = 1, NB
C
C                  SOLVE THE K BY K TRIANGULAR SYSTEM.
C                 ..
                  DO 260 L = 1, K
                     SM = DZERO
                     I = KP1 - L
                     IP1 = I + 1
                     IF (K .LT. IP1) GO TO 250
                     DO 240 J = IP1, K
                        SM = SM + A(I,J)*B(J,JB)
  240                CONTINUE
  250                CONTINUE
                     SM1 = SM
                     B(I,JB) = (B(I,JB) - SM1)/A(I,I)
  260             CONTINUE
C
C                  COMPLETE COMPUTATION OF SOLUTION VECTOR.
C                 ..
                  IF (K .EQ. N) GO TO 290
                     DO 270 J = KP1, N
                        B(J,JB) = SZERO
  270                CONTINUE
                     DO 280 I = 1, K
                        CALL DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,
     *                            MDB,1)
  280                CONTINUE
  290             CONTINUE
C
C                   RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C                   COLUMN INTERCHANGES.
C                 ..
                  DO 310 JJ = 1, LDIAG
                     J = LDIAG + 1 - JJ
                     IF (IP(J) .EQ. J) GO TO 300
                        L = IP(J)
                        TMP = B(L,JB)
                        B(L,JB) = B(J,JB)
                        B(J,JB) = TMP
  300                CONTINUE
  310             CONTINUE
  320          CONTINUE
  330          CONTINUE
  340       CONTINUE
  350    CONTINUE
C        ..
C         THE SOLUTION VECTORS, X, ARE NOW
C         IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
         KRANK = K
  360 CONTINUE
      RETURN
      END


program t
  print '(i0)',1+2*3
  print '(f3.1)',1+2*3/4.0
  print '(i0)',2**3-1
end program t