!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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 genbun(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
!
!
! DIMENSION OF           a(m), b(m), c(m), y(idimy, n)
! ARGUMENTS
!
! LATEST REVISION        April 2016
!
! PURPOSE                The name of this package is a mnemonic for the
!                        generalized buneman algorithm.
!
!                        It solves the real linear system of equations
!
!                        a(i)*x(i-1, j) + b(i)*x(i, j) + c(i)*x(i+1, j)
!                        + x(i, j-1) - 2.0*x(i, j) + x(i, j+1) = y(i, j)
!
!                        for i = 1, 2, ..., m  and  j = 1, 2, ..., n.
!
!                        indices i+1 and i-1 are evaluated modulo m,
!                        i.e., x(0, j) = x(m, j) and x(m+1, j) = x(1, j),
!                        and x(i, 0) may equal 0, x(i, 2), or x(i, n),
!                        and x(i, n+1) may equal 0, x(i, n-1), or x(i, 1)
!                        depending on an input parameter.
!
! USAGE                  call genbun(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
!
! ARGUMENTS
!
! ON INPUT               nperod
!
!                          Indicates the values that x(i, 0) and
!                          x(i, n+1) are assumed to have.
!
!                          = 0  if x(i, 0) = x(i, n) and x(i, n+1) =
!                               x(i, 1).
!                          = 1  if x(i, 0) = x(i, n+1) = 0  .
!                          = 2  if x(i, 0) = 0 and x(i, n+1) = x(i, n-1).
!                          = 3  if x(i, 0) = x(i, 2) and x(i, n+1) =
!                               x(i, n-1).
!                          = 4  if x(i, 0) = x(i, 2) and x(i, n+1) = 0.
!
!                        n
!                          The number of unknowns in the j-direction.
!                          n must be greater than 2.
!
!                        mperod
!                          = 0 if a(1) and c(m) are not zero
!                          = 1 if a(1) = c(m) = 0
!
!                        m
!                          The number of unknowns in the i-direction.
!                          n must be greater than 2.
!
!                        a, b, c
!                          One-dimensional arrays of length m that
!                          specify the coefficients in the linear
!                          equations given above.  if mperod = 0
!                          the array elements must not depend upon
!                          the index i, but must be constant.
!                          specifically, the subroutine checks the
!                          following condition .
!
!                            a(i) = c(1)
!                            c(i) = c(1)
!                            b(i) = b(1)
!
!                          for i=1, 2, ..., m.
!
!                        idimy
!                          The row (or first) dimension of the
!                          two-dimensional array y as it appears
!                          in the program calling genbun.
!                          this parameter is used to specify the
!                          variable dimension of y.
!                          idimy must be at least m.
!
!                        y
!                          A two-dimensional complex array that
!                          specifies the values of the right side
!                          of the linear system of equations given
!                          above.
!                          y must be dimensioned at least m*n.
!
!
!  ON OUTPUT             y
!
!                          Contains the solution x.
!
!                        ierror
!                          An error flag which indicates invalid
!                          input parameters  except for number
!                          zero, a solution is not attempted.
!
!                          = 0  no error
!                          = 1  m <= 2
!                          = 2  n <= 2
!                          = 3  idimy <= m
!                          = 4  nperod <= 0 or nperod > 4
!                          = 5  mperod < 0 or mperod > 1
!                          = 6  a(i) /= c(1) or c(i) /= c(1) or
!                               b(i) /= b(1) for
!                               some i=1, 2, ..., m.
!                          = 7  a(1) /= 0 or c(m) /= 0 and
!                                 mperod = 1
!                          = 20 If the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails (for example if n, m are too large
!                               for your computer)
!
!
! HISTORY                Written in 1979 by Roland Sweet of NCAR'S
!                        scientific computing division. made available
!                        on NCAR'S public libraries in January, 1980.
!
!                        Revised in June 2004 by John Adams using
!                        Fortran 90 dynamically allocated workspace.
!
! ALGORITHM              The linear system is solved by a cyclic
!                        reduction algorithm described in the
!                        reference.
!
! PORTABILITY            Fortran 2008 --
!                        the machine dependent constant pi is
!                        defined as acos(-ONE) where wp = REAL64
!                        from the intrinsic module ISO_Fortran_env.
!
! REFERENCES             Sweet, R., "A cyclic reduction algorithm for
!                        solving block tridiagonal systems of arbitrary
!                        dimensions, " SIAM J. On Numer. Anal., 14 (1977)
!                        PP. 706-720.
!
! ACCURACY               This test was performed on a platform with
!                        64 bit floating point arithmetic.
!                        a uniform random number generator was used
!                        to create a solution array x for the system
!                        given in the 'purpose' description above
!                        with
!                          a(i) = c(i) = -HALF *b(i) = 1, i=1, 2, ..., m
!
!                        and, when mperod = 1
!
!                          a(1) = c(m) = 0
!                          a(m) = c(1) = 2.
!
!                        The solution x was substituted into the
!                        given system  and, using double precision
!                        a right side y was computed.
!                        using this array y, subroutine genbun
!                        was called to produce approximate
!                        solution z.  then relative error
!                          e = max(abs(z(i, j)-x(i, j)))/
!                              max(abs(x(i, j)))
!                        was computed, where the two maxima are taken
!                        over i=1, 2, ..., m and j=1, ..., n.
!
!                        The value of e is given in the table
!                        below for some typical values of m and n.
!
!                   m (=n)    mperod    nperod        e
!                   ------    ------    ------      ------
!
!                     31        0         0         6.e-14
!                     31        1         1         4.e-13
!                     31        1         3         3.e-13
!                     32        0         0         9.e-14
!                     32        1         1         3.e-13
!                     32        1         3         1.e-13
!                     33        0         0         9.e-14
!                     33        1         1         4.e-13
!                     33        1         3         1.e-13
!                     63        0         0         1.e-13
!                     63        1         1         1.e-12
!                     63        1         3         2.e-13
!                     64        0         0         1.e-13
!                     64        1         1         1.e-12
!                     64        1         3         6.e-13
!                     65        0         0         2.e-13
!                     65        1         1         1.e-12
!                     65        1         3         4.e-13
!
module type_CenteredCyclicReductionUtility

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip ! Integer precision

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use type_CyclicReductionUtility, only: &
        CyclicReductionUtility

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: CenteredCyclicReductionUtility

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp

    type, public, extends(CyclicReductionUtility) :: CenteredCyclicReductionUtility
    contains
        ! Public type-bound procedures
        procedure, public :: genbun_lower_routine
        ! Private type-bound procedures
        procedure, private :: genbun_solve_poisson_periodic
        procedure, private :: genbun_solve_poisson_dirichlet
        procedure, private :: genbun_solve_poisson_neumann
    end type

contains

    subroutine genbun_lower_routine(self, &
        nperod, n, mperod, m, a, b, c, idimy, y, ierror, w)

        ! Dummy arguments
        class(CenteredCyclicReductionUtility), intent(inout) :: self
        integer(ip), intent(in)    :: nperod
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: mperod
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: idimy
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: a(m)
        real(wp),    intent(in)    :: b(m)
        real(wp),    intent(in)    :: c(m)
        real(wp),    intent(inout) :: y(idimy,n)
        real(wp),    intent(inout) :: w(:)

        ! Local variables
        integer(ip)     :: workspace_indices(12)
        integer(ip)     :: i, k, j, mp, np, irev, mh, mhm1, modd
        integer(ip)     :: nby2, mskip
        real(wp)        :: ipstor

        ! Check input arguments
        call genbun_check_input_arguments(nperod, n, mperod, m, idimy, ierror, a, b, c)

        ! Check error flag
        if (ierror /= 0) return

        !
        ! Set up workspace for lower routine poisson solvers
        !
        workspace_indices = genbun_get_workspace_indices(n, m)

        associate( &
            mp1 => workspace_indices(1), &
            iwba => workspace_indices(2), &
            iwbb => workspace_indices(3), &
            iwbc => workspace_indices(4), &
            iwb2 => workspace_indices(5), &
            iwb3 => workspace_indices(6), &
            iww1 => workspace_indices(7), &
            iww2 => workspace_indices(8), &
            iww3 => workspace_indices(9), &
            iwd => workspace_indices(10), &
            iwtcos => workspace_indices(11), &
            iwp => workspace_indices(12) &
            )

            w(iwba:m-1+iwba) = -a(:m)
            w(iwbc:m-1+iwbc) = -c(:m)
            w(iwbb:m-1+iwbb) = TWO - b(:m)
            y(:m, :n) = -y(:m, :n)

            mp = mperod + 1
            np = nperod + 1

            select case (mp)
                case (1)
                    mh = (m + 1)/2
                    mhm1 = mh - 1

                    if (mh*2 == m) then
                        modd = 2
                    else
                        modd = 1
                    end if

                    do j = 1, n
                        w(:mhm1) = y(mh-1:mh-mhm1:(-1), j) - y(mh+1:mhm1+mh, j)
                        w(mh+1:mhm1+mh) = y(mh-1:mh-mhm1:(-1), j) + y(mh+1:mhm1+mh, j)
                        w(mh) = TWO*y(mh, j)
                        select case (modd)
                            case (1)
                                y(:m, j) = w(:m)
                            case (2)
                                w(m) = TWO * y(m, j)
                                y(:m, j) = w(:m)
                        end select
                    end do

                    k = iwbc + mhm1 - 1
                    i = iwba + mhm1
                    w(k) = ZERO
                    w(i) = ZERO
                    w(k+1) = TWO * w(k+1)

                    select case (modd)
                        case default
                            k = iwbb + mhm1 - 1
                            w(k) = w(k) - w(i-1)
                            w(iwbc-1) = w(iwbc-1) + w(iwbb-1)
                        case (2)
                            w(iwbb-1) = w(k+1)
                    end select
            end select

            main_loop: do

                associate( &
                    ba => w(iwba:), &
                    bb => w(iwbb:), &
                    bc => w(iwbc:), &
                    b2 => w(iwb2:), &
                    b3 => w(iwb3:), &
                    w1 => w(iww1:), &
                    w2 => w(iww2:), &
                    w3 => w(iww3:), &
                    d => w(iwd:), &
                    tcos => w(iwtcos:), &
                    p => w(iwp:) &
                    )
                    !
                    ! Invoke lower routines
                    !
                    select case (np)
                        case (1)
                            call self%genbun_solve_poisson_periodic(m, n, ba, bb, bc, &
                                y, idimy, w, b2, b3, w1, w2, w3, d, tcos, p)
                        case (2)
                            call self%genbun_solve_poisson_dirichlet(m, n, 1, ba, bb, bc, &
                                y, idimy, w, w1, d, tcos, p)
                        case (3)
                            call self%genbun_solve_poisson_neumann(m, n, 1, 2, ba, bb, bc, &
                                y, idimy, w, b2, b3, w1, w2, w3, d, tcos, p)
                        case (4)
                            call self%genbun_solve_poisson_neumann(m, n, 1, 1, ba, bb, bc, &
                                y, idimy, w, b2, b3, w1, w2, w3, d, tcos, p)
                    end select
                end associate

                loop_113: do

                    select case (np)
                        case (1:4)
                            select case (mp)
                                case (1)
                                    do j = 1, n
                                        w(mh-1:mh-mhm1:(-1)) = HALF*(y(mh+1:mhm1+mh, j)+y(:mhm1, j))
                                        w(mh+1:mhm1+mh) = HALF*(y(mh+1:mhm1+mh, j)-y(:mhm1, j))
                                        w(mh) = HALF*y(mh, j)
                                        select case (modd)
                                            case (1)
                                                y(:m, j) = w(:m)
                                            case (2)
                                                w(m) = HALF*y(m, j)
                                                y(:m, j) = w(:m)
                                        end select
                                    end do
                                    w(1) = ipstor + real(iwp - 1, kind=wp)
                                    return
                                case (2)
                                    w(1) = ipstor + real(iwp - 1, kind=wp)
                                    return
                            end select

                            mh = (m + 1)/2
                            mhm1 = mh - 1

                            if (mh*2 == m) then
                                modd = 2
                            else
                                modd = 1
                            end if

                            do j = 1, n
                                w(:mhm1) = y(mh-1:mh-mhm1:(-1), j) - y(mh+1:mhm1+mh, j)
                                w(mh+1:mhm1+mh) = y(mh-1:mh-mhm1:(-1), j) + y(mh+1:mhm1+mh, j)
                                w(mh) = TWO*y(mh, j)
                                select case (modd)
                                    case (1)
                                        y(:m, j) = w(:m)
                                    case (2)
                                        w(m) = TWO*y(m, j)
                                        y(:m, j) = w(:m)
                                end select
                            end do

                            k = iwbc + mhm1 - 1
                            i = iwba + mhm1
                            w(k) = ZERO
                            w(i) = ZERO
                            w(k+1) = TWO*w(k+1)

                            select case (modd)
                                case (2)
                                    w(iwbb-1) = w(k+1)
                                case default
                                    k = iwbb + mhm1 - 1
                                    w(k) = w(k) - w(i-1)
                                    w(iwbc-1) = w(iwbc-1) + w(iwbb-1)
                            end select

                            cycle main_loop
                        !
                        !     reverse columns when nperod = 4.
                        !
                    end select

                    irev = 1
                    nby2 = n/2

                    loop_124: do

                        do j = 1, nby2
                            mskip = n + 1 - j
                            do i = 1, m
                                call self%swap(y(i, j), y(i, mskip))
                            end do
                        end do

                        select case (irev)
                            case (1)
                                associate( &
                                    ba => w(iwba:), &
                                    bb => w(iwbb:), &
                                    bc => w(iwbc:), &
                                    b2 => w(iwb2:), &
                                    b3 => w(iwb3:), &
                                    w1 => w(iww1:), &
                                    w2 => w(iww2:), &
                                    w3 => w(iww3:), &
                                    d => w(iwd:), &
                                    tcos => w(iwtcos:), &
                                    p => w(iwp:) &
                                    )
                                    call self%genbun_solve_poisson_neumann(m, n, 1, 2, ba, bb, bc, &
                                        y, idimy, w, b2, b3, w1, w2, w3, d, tcos, p)
                                end associate

                                ipstor = w(iww1)
                                irev = 2

                                if (nperod == 4) cycle loop_124
                                cycle loop_113

                            case (2)
                                cycle loop_113
                        end select
                        exit loop_124
                    end do loop_124
                    exit loop_113
                end do loop_113
            end do main_loop

            do j = 1, n
                w(mh-1:mh-mhm1:(-1)) = HALF*(y(mh+1:mhm1+mh, j)+y(:mhm1, j))
                w(mh+1:mhm1+mh) = HALF*(y(mh+1:mhm1+mh, j)-y(:mhm1, j))
                w(mh) = HALF*y(mh, j)
                select case (modd)
                    case (1)
                        y(:m, j) = w(:m)
                    case (2)
                        w(m) = HALF*y(m, j)
                        y(:m, j) = w(:m)
                end select
            end do

            w(1) = ipstor + real(iwp - 1, kind=wp)

        end associate

    end subroutine genbun_lower_routine

    pure subroutine genbun_check_input_arguments(nperod, n, mperod, m, idimy, ierror, a, b, c)

        ! Dummy arguments
        integer(ip), intent(in)  :: nperod
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: mperod
        integer(ip), intent(in)  :: m
        integer(ip), intent(in)  :: idimy
        integer(ip), intent(out) :: ierror
        real(wp),    intent(in)  :: a(m)
        real(wp),    intent(in)  :: b(m)
        real(wp),    intent(in)  :: c(m)

        if (3 > m) then
            ierror = 1
            return
        else if (3 > n) then
            ierror = 2
            return
        else if (idimy < m) then
            ierror = 3
            return
        else if (nperod < 0 .or. nperod > 4) then
            ierror = 4
            return
        else if (mperod < 0 .or. mperod > 1) then
            ierror = 5
            return
        else if (mperod /= 1) then
            if (any(a /= c(1)) .or. any(c /= c(1)) .or. any(b /= b(1))) then
                ierror = 6
                return
            end if
        else if (a(1) /= ZERO .or. c(m) /= ZERO) then
            ierror = 7
            return
        else
            ierror = 0
        end if

    end subroutine genbun_check_input_arguments

    function genbun_get_workspace_indices(n, m) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: n
        integer(ip), intent(in) :: m
        integer(ip)             :: return_value(12)

        integer(ip) :: j !! Counter

        associate( i => return_value)
            i(1:2) = m + 1
            do j = 3, 11
                i(j) = i(j-1) + m
            end do
            i(12) = i(11) + 4 * n
        end associate

    end function genbun_get_workspace_indices

    !
    ! Purpose:
    !
    !     Solve poisson equation with periodic
    !     boundary conditions.
    !
    subroutine genbun_solve_poisson_periodic(self, &
        m, n, a, bb, c, q, idimq, b, b2, b3, w, w2, w3, d, tcos, p)

        ! Dummy arguments
        class(CenteredCyclicReductionUtility), intent(inout) :: self
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: idimq
        real(wp),    intent(in)    :: a(m)
        real(wp),    intent(in)    :: bb(m)
        real(wp),    intent(in)    :: c(m)
        real(wp),    intent(inout) :: q(idimq,m)
        real(wp),    intent(inout) :: b(m)
        real(wp),    intent(inout) :: b2(m)
        real(wp),    intent(inout) :: b3(m)
        real(wp),    intent(inout) :: w(m)
        real(wp),    intent(inout) :: w2(m)
        real(wp),    intent(inout) :: w3(m)
        real(wp),    intent(inout) :: d(m)
        real(wp),    intent(inout) :: tcos(m)
        real(wp),    intent(inout) :: p(4*n)

        ! Local variables
        integer(ip) :: mr, nr, nrm1, j, nrmj, nrpj, i, lh
        real(wp)    :: ipstor
        real(wp)    :: s, t

        mr = m
        nr = (n + 1)/2
        nrm1 = nr - 1

        if (2*nr == n) then

            ! even number of unknowns
            do j = 1, nrm1
                nrmj = nr - j
                nrpj = nr + j
                do i = 1, mr
                    s = q(i, nrmj) - q(i, nrpj)
                    t = q(i, nrmj) + q(i, nrpj)
                    q(i, nrmj) = s
                    q(i, nrpj) = t
                end do
            end do

            q(:mr, nr) = TWO * q(:mr, nr)
            q(:mr, n) = TWO * q(:mr, n)

            call self%genbun_solve_poisson_dirichlet(mr, nrm1, 1, a, bb, c, q, idimq, b, w, d, tcos, p)

            ipstor = w(1)

            call self%genbun_solve_poisson_neumann(mr, (nr + 1), 1, 1, a, bb, c, q(1, nr), idimq, b, b2, &
                b3, w, w2, w3, d, tcos, p)

            ipstor = max(ipstor, w(1))

            do j = 1, nrm1
                nrmj = nr - j
                nrpj = nr + j
                do i = 1, mr
                    s = HALF*(q(i, nrpj)+q(i, nrmj))
                    t = HALF*(q(i, nrpj)-q(i, nrmj))
                    q(i, nrmj) = s
                    q(i, nrpj) = t
                end do
            end do
            q(:mr, nr) = HALF*q(:mr, nr)
            q(:mr, n) = HALF*q(:mr, n)
        else
            do j = 1, nrm1
                nrpj = n + 1 - j
                do i = 1, mr
                    s = q(i, j) - q(i, nrpj)
                    t = q(i, j) + q(i, nrpj)
                    q(i, j) = s
                    q(i, nrpj) = t
                end do
            end do

            q(:mr, nr) = TWO*q(:mr, nr)
            lh = nrm1/2

            do j = 1, lh
                nrmj = nr - j
                do i = 1, mr
                    s = q(i, j)
                    q(i, j) = q(i, nrmj)
                    q(i, nrmj) = s
                end do
            end do

            call self%genbun_solve_poisson_dirichlet(mr, nrm1, 2, a, bb, c, q, &
                idimq, b, w, d, tcos, p)

            ipstor = w(1)

            call self%genbun_solve_poisson_neumann(mr, nr, 2, 1, a, bb, c, q(1, nr), &
                idimq, b, b2, b3, w, w2, w3, d, tcos, p)

            ipstor = max(ipstor, w(1))

            do j = 1, nrm1
                nrpj = nr + j
                do i = 1, mr
                    s = HALF*(q(i, nrpj)+q(i, j))
                    t = HALF*(q(i, nrpj)-q(i, j))
                    q(i, nrpj) = t
                    q(i, j) = s
                end do
            end do

            q(:mr, nr) = HALF*q(:mr, nr)

            do j = 1, lh
                nrmj = nr - j
                do i = 1, mr
                    s = q(i, j)
                    q(i, j) = q(i, nrmj)
                    q(i, nrmj) = s
                end do
            end do
        end if

        w(1) = ipstor

    end subroutine genbun_solve_poisson_periodic

    !
    ! Purpose:
    !
    !     subroutine to solve poisson's equation for dirichlet boundary
    !     conditions.
    !
    !     istag = 1 if the last diagonal block is the matrix a.
    !     istag = 2 if the last diagonal block is the matrix a+i.
    !
    subroutine genbun_solve_poisson_dirichlet(self, &
        mr, nr, istag, ba, bb, bc, q, idimq, b, w, d, tcos, p)

        ! Dummy arguments
        class(CenteredCyclicReductionUtility), intent(inout) :: self
        integer(ip), intent(in)    :: mr
        integer(ip), intent(in)    :: nr
        integer(ip), intent(in)    :: istag
        integer(ip), intent(in)    :: idimq
        real(wp),    intent(in)    :: ba(:)
        real(wp),    intent(in)    :: bb(:)
        real(wp),    intent(in)    :: bc(:)
        real(wp),    intent(inout) :: q(:,:)
        real(wp),    intent(inout) :: b(:)
        real(wp),    intent(inout) :: w(:)
        real(wp),    intent(inout) :: d(:)
        real(wp),    intent(inout) :: tcos(:)
        real(wp),    intent(inout) :: p(:)

        ! Local variables
        integer(ip)     :: m, n, jsh, ipp, ipstor, kr
        integer(ip)     :: irreg, jstsav, i, lr, nun, nodd, noddpr
        integer(ip)     :: jst, jsp, l, j, jm1, jp1, jm2, jp2, jm3, jp3
        integer(ip)     :: krpi, ideg, jdeg
        real(wp)        :: fi, t

        m = mr
        n = nr
        jsh = 0
        fi = ONE/istag
        ipp = -m
        ipstor = 0

        select case (istag)
            case (2)
                kr = 1
                jstsav = 1
                irreg = 2
                if (n <= 1) then
                    tcos(1) = -ONE
                    b(:m) = q(:m, 1)
                    call self%solve_tridiag(1, 0, m, ba, bb, bc, b, tcos, d, w)
                    q(:m, 1) = b(:m)
                    w(1) = ipstor
                    return
                end if
            case default
                kr = 0
                irreg = 1
                if (n <= 1) then
                    tcos(1) = ZERO
                    b(:m) = q(:m, 1)
                    call self%solve_tridiag(1, 0, m, ba, bb, bc, b, tcos, d, w)
                    q(:m, 1) = b(:m)
                    w(1) = ipstor
                    return
                end if
        end select

        lr = 0
        p(:m) = ZERO
        nun = n
        jst = 1
        jsp = n
        !
        ! irreg = 1 when no irregularities have occurred, otherwise it is 2.
        !
        loop_108: do

            l = 2*jst
            nodd = 2 - 2*((nun + 1)/2) + nun
            !
            ! nodd = 1 when nun is odd, otherwise it is 2.
            !
            select case (nodd)
                case (1)
                    jsp = jsp - jst
                    if (irreg /= 1) then
                        jsp = jsp - l
                    end if
                case default
                    jsp = jsp - l
            end select

            call self%generate_cosines(jst, 1, HALF, ZERO, tcos)

            if (l <= jsp) then
                do j = l, jsp, l
                    jm1 = j - jsh
                    jp1 = j + jsh
                    jm2 = j - jst
                    jp2 = j + jst
                    jm3 = jm2 - jsh
                    jp3 = jp2 + jsh

                    if (jst == 1) then
                        b(:m) = TWO*q(:m, j)
                        q(:m, j) = q(:m, jm2) + q(:m, jp2)
                    else
                        do i = 1, m
                            t = q(i, j) - q(i, jm1) - q(i, jp1) + q(i, jm2) + q(i, jp2)
                            b(i) = t + q(i, j) - q(i, jm3) - q(i, jp3)
                            q(i, j) = t
                        end do
                    end if

                    call self%solve_tridiag(jst, 0, m, ba, bb, bc, b, tcos, d, w)
                    q(:m, j) = q(:m, j) + b(:m)

                end do
            end if
            !
            ! reduction for last unknown
            !
            case_block: block
                select case (nodd)
                    !
                    ! even number of unknowns
                    !
                    case (2)
                        jsp = jsp + l
                        j = jsp
                        jm1 = j - jsh
                        jp1 = j + jsh
                        jm2 = j - jst
                        jp2 = j + jst
                        jm3 = jm2 - jsh

                        select case (irreg)
                            case (2)
                                call self%generate_cosines(kr, jstsav, ZERO, fi, tcos)
                                call self%generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1:))
                                ideg = kr
                                kr = kr + jst
                            case default
                                jstsav = jst
                                ideg = jst
                                kr = l
                        end select

                        if (jst == 1) then
                            irreg = 2
                            b(:m) = q(:m, j)
                            q(:m, j) = q(:m, jm2)
                        else
                            b(:m) = q(:m, j) + HALF*(q(:m, jm2)-q(:m, jm1)-q(:m, jm3))
                            select case (irreg)
                                case (2)
                                    select case (noddpr)
                                        case (2)
                                            q(:m, j) = q(:m, jm2) + q(:m, j) - q(:m, jm1)
                                        case default
                                            q(:m, j) = q(:m, jm2) + p(ipp+1:m+ipp)
                                            ipp = ipp - m
                                    end select
                                case default
                                    q(:m, j) = q(:m, jm2) + HALF *(q(:m, j)-q(:m, jm1)-q(:m, jp1))
                                    irreg = 2
                            end select
                        end if

                        call self%solve_tridiag(ideg, lr, m, ba, bb, bc, b, tcos, d, w)
                        q(:m, j) = q(:m, j) + b(:m)

                    case default
                        !
                        ! odd number of unknowns
                        !
                        if (irreg == 1) exit case_block

                        jsp = jsp + l
                        j = jsp
                        jm1 = j - jsh
                        jp1 = j + jsh
                        jm2 = j - jst
                        jp2 = j + jst
                        jm3 = jm2 - jsh

                        select case (istag)
                            case (1)
                                select case (noddpr)
                                    case (2)
                                        b(:m) = HALF*(q(:m, jm2)-q(:m, jm1)-q(:m, jm3)) &
                                            + q(:m, jp2) - q(:m, jp1) + q(:m, j)
                                    case default
                                        b(:m) = HALF*(q(:m, jm2)-q(:m, jm1)&
                                            -q(:m, jm3)) + p(ipp+1:m+ipp) + q(:m, j)
                                end select

                                q(:m, j) = HALF *(q(:m, j)-q(:m, jm1)-q(:m, jp1))
                            case (2)
                                if (jst /= 1) then
                                    select case (noddpr)
                                        case (2)
                                            b(:m) = HALF*(q(:m, jm2)-q(:m, jm1)-q(:m, jm3)) &
                                                + q(:m, jp2) - q(:m, jp1) + q(:m, j)
                                        case default
                                            b(:m) = HALF*(q(:m, jm2)-q(:m, jm1)&
                                                -q(:m, jm3)) + p(ipp+1:m+ipp) + q(:m, j)
                                    end select
                                    q(:m, j) = HALF *(q(:m, j)-q(:m, jm1)-q(:m, jp1))
                                else

                                    b(:m) = q(:m, j)
                                    q(:m, j) = ZERO
                                end if
                        end select

                        call self%solve_tridiag(jst, 0, m, ba, bb, bc, b, tcos, d, w)

                        ipp = ipp + m
                        ipstor = max(ipstor, ipp + m)
                        p(ipp+1:m+ipp) = q(:m, j) + b(:m)
                        b(:m) = q(:m, jp2) + p(ipp+1:m+ipp)

                        if (lr == 0) then
                            do i = 1, jst
                                krpi = kr + i
                                tcos(krpi) = tcos(i)
                            end do
                        else
                            call self%generate_cosines(lr, jstsav, ZERO, fi, tcos(jst+1:))
                            call self%merge_cosines(tcos, 0, jst, jst, lr, kr)
                        end if

                        call self%generate_cosines(kr, jstsav, ZERO, fi, tcos)
                        call self%solve_tridiag(kr, kr, m, ba, bb, bc, b, tcos, d, w)

                        q(:m, j) = q(:m, jm2) + b(:m) + p(ipp+1:m+ipp)
                        lr = kr
                        kr = kr + l

                end select
            end block case_block

            nun = nun/2
            noddpr = nodd
            jsh = jst
            jst = 2*jst

            if (nun < 2) exit loop_108
        end do loop_108
        !
        ! start solution.
        !
        j = jsp
        b(:m) = q(:m, j)

        select case (irreg)
            case (2)
                kr = lr + jst
                call self%generate_cosines(kr, jstsav, ZERO, fi, tcos)
                call self%generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1:))
                ideg = kr
            case default
                call self%generate_cosines(jst, 1, HALF, ZERO, tcos)
                ideg = jst
        end select

        call self%solve_tridiag(ideg, lr, m, ba, bb, bc, b, tcos, d, w)
        jm1 = j - jsh
        jp1 = j + jsh

        select case (irreg)
            case (2)
                select case (noddpr)
                    case (2)
                        q(:m, j) = q(:m, j) - q(:m, jm1) + b(:m)
                    case default
                        q(:m, j) = p(ipp+1:m+ipp) + b(:m)
                        ipp = ipp - m
                end select
            case default
                q(:m, j) = HALF *(q(:m, j)-q(:m, jm1)-q(:m, jp1)) + b(:m)
        end select

        loop_164: do

            jst = jst/2
            jsh = jst/2
            nun = 2*nun

            if (nun > n) then
                w(1) = ipstor
                return
            end if

            inner_loop: do j = jst, n, l
                jm1 = j - jsh
                jp1 = j + jsh
                jm2 = j - jst
                jp2 = j + jst

                block_construct: block
                    if (j <= jst) then
                        b(:m) = q(:m, j) + q(:m, jp2)
                    else
                        if (jp2 > n) then
                            b(:m) = q(:m, j) + q(:m, jm2)
                            if (jst < jstsav) irreg = 1
                            select case (irreg)
                                case (2)
                                    if (j + l > n) lr = lr - jst
                                    kr = jst + lr
                                    call self%generate_cosines(kr, jstsav, ZERO, fi, tcos)
                                    call self%generate_cosines(lr, jstsav, ZERO, fi, tcos(kr+1:))
                                    ideg = kr
                                    jdeg = lr
                                    exit block_construct
                            end select
                        else
                            b(:m) = q(:m, j) + q(:m, jm2) + q(:m, jp2)
                        end if
                    end if

                    call self%generate_cosines(jst, 1, HALF, ZERO, tcos)
                    ideg = jst
                    jdeg = 0

                end block block_construct

                call self%solve_tridiag(ideg, jdeg, m, ba, bb, bc, b, tcos, d, w)

                if_construct: if (jst <= 1) then
                    q(:m, j) = b(:m)
                else
                    if (jp2 > n) then
                        select case (irreg)
                            case (2)
                                if (j + jsh <= n) then
                                    q(:m, j) = b(:m) + p(ipp+1:m+ipp)
                                    ipp = ipp - m
                                else
                                    q(:m, j) = b(:m) + q(:m, j) - q(:m, jm1)
                                end if
                                exit if_construct
                        end select
                    end if

                    loop_175: do
                        q(:m, j) = HALF *(q(:m, j)-q(:m, jm1)-q(:m, jp1)) + b(:m)
                        cycle inner_loop
                        select case (irreg)
                            case (1)
                                cycle loop_175
                            case (2)
                                if (j + jsh <= n) then
                                    q(:m, j) = b(:m) + p(ipp+1:m+ipp)
                                    ipp = ipp - m
                                else
                                    q(:m, j) = b(:m) + q(:m, j) - q(:m, jm1)
                                end if
                                exit loop_175
                        end select
                    end do loop_175
                end if if_construct
            end do inner_loop

            l = l/2

        end do loop_164

        w(1) = ipstor

    end subroutine genbun_solve_poisson_dirichlet

    !
    ! Purpose
    !
    !     To solve poisson's equation with neumann boundary
    !     conditions.
    !
    !     istag = 1 if the last diagonal block is a.
    !     istag = 2 if the last diagonal block is a-i.
    !     mixbnd = 1 if have neumann boundary conditions at both boundaries.
    !     mixbnd = 2 if have neumann boundary conditions at bottom and
    !     dirichlet condition at top.  (for this case, must have istag = 1.)
    !
    subroutine genbun_solve_poisson_neumann(self, &
        m, n, istag, mixbnd, a, bb, c, q, idimq, b, b2, &
        b3, w, w2, w3, d, tcos, p)

        ! Dummy arguments
        class(CenteredCyclicReductionUtility), intent(inout) :: self
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: istag
        integer(ip), intent(in)     :: mixbnd
        integer(ip), intent(in)     :: idimq
        real(wp),    intent(in)     :: a(m)
        real(wp),    intent(in)     :: bb(m)
        real(wp),    intent(in)     :: c(m)
        real(wp),    intent(inout) :: q(idimq,m)
        real(wp),    intent(inout) :: b(m)
        real(wp),    intent(inout) :: b2(m)
        real(wp),    intent(inout) :: b3(m)
        real(wp),    intent(inout) :: w(m)
        real(wp),    intent(inout) :: w2(m)
        real(wp),    intent(inout) :: w3(m)
        real(wp),    intent(inout) :: d(m)
        real(wp),    intent(inout) :: tcos(m)
        real(wp),    intent(inout) :: p(4*n)

        ! Local variables
        integer(ip)     :: k(4)
        integer(ip)     :: mr, ipp, ipstor, i2r, jr, nr, nlast, kr
        integer(ip)     :: lr, i, nrod, jstart, jstop, i2rby2, j, jp1, jp2, jp3, jm1
        integer(ip)     :: jm2, jm3, nrodpr, ii, i1, i2, jr2, nlastp, jstep
        real(wp)        :: fistag, fnum, fden, fi, t

        associate( &
            k1 => k(1), &
            k2 => k(2), &
            k3 => k(3), &
            k4 => k(4) &
            )

            fistag = 3 - istag
            fnum = ONE/istag
            fden = HALF * real(istag - 1, kind=wp)
            mr = m
            ipp = -mr
            ipstor = 0
            i2r = 1
            jr = 2
            nr = n
            nlast = n
            kr = 1
            lr = 0

            select case (istag)
                case (1)
                    goto 101
                case (2)
                    goto 103
            end select

101     continue

        q(:mr, n) = HALF * q(:mr, n)

        select case (mixbnd)
            case (1)
                goto 103
            case (2)
                goto 104
        end select

103 continue

    if (n <= 3) then
        goto 155
    end if

104 continue

    jr = 2*i2r

    if ((nr/2)*2 == nr) then
        nrod = 0
    else
        nrod = 1
    end if

    select case (mixbnd)
        case default
            jstart = 1
        case (2)
            jstart = jr
            nrod = 1 - nrod
    end select

    jstop = nlast - jr

    if (nrod == 0) then
        jstop = jstop - i2r
    end if

    call self%generate_cosines(i2r, 1, HALF, ZERO, tcos)

    i2rby2 = i2r/2

    if (jstop < jstart) then
        j = jr
    else
        do j = jstart, jstop, jr
            jp1 = j + i2rby2
            jp2 = j + i2r
            jp3 = jp2 + i2rby2
            jm1 = j - i2rby2
            jm2 = j - i2r
            jm3 = jm2 - i2rby2

            if (j == 1) then
                jm1 = jp1
                jm2 = jp2
                jm3 = jp3
            end if

            if (i2r == 1) then
                if (j == 1) jm2 = jp2
                b(:mr) = TWO*q(:mr, j)
                q(:mr, j) = q(:mr, jm2) + q(:mr, jp2)
            else
                do i = 1, mr
                    fi = q(i, j)
                    q(i, j)=q(i, j)-q(i, jm1)-q(i, jp1)+q(i, jm2)+q(i, jp2)
                    b(i) = fi + q(i, j) - q(i, jm3) - q(i, jp3)
                end do
            end if

            call self%solve_tridiag(i2r, 0, mr, a, bb, c, b, tcos, d, w)

            q(:mr, j) = q(:mr, j) + b(:mr)
            !
            ! end of reduction for regular unknowns.
            !
        end do
        !
        ! begin special reduction for last unknown.
        !
        j = jstop + jr
    end if

    nlast = j
    jm1 = j - i2rby2
    jm2 = j - i2r
    jm3 = jm2 - i2rby2

    if (nrod /= 0) then
        !
        !     odd number of unknowns
        !
        if (i2r == 1) then
            b(:mr) = fistag*q(:mr, j)
            q(:mr, j) = q(:mr, jm2)
        else
            b(:mr) = q(:mr, j) + HALF*(q(:mr, jm2)-q(:mr, jm1)-q(:mr, jm3))
            if (nrodpr == 0) then
                q(:mr, j) = q(:mr, jm2) + p(ipp+1:mr+ipp)
                ipp = ipp - mr
            else
                q(:mr, j) = q(:mr, j) - q(:mr, jm1) + q(:mr, jm2)
            end if
            if (lr /= 0) then
                call self%generate_cosines(lr, 1, HALF, fden, tcos(kr+1:))
            else
                b(:mr) = fistag*b(:mr)
            end if
        end if
        call self%generate_cosines(kr, 1, HALF, fden, tcos)
        call self%solve_tridiag(kr, lr, mr, a, bb, c, b, tcos, d, w)
        q(:mr, j) = q(:mr, j) + b(:mr)
        kr = kr + i2r
    else
        jp1 = j + i2rby2
        jp2 = j + i2r
        if (i2r == 1) then
            b(:mr) = q(:mr, j)
            call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)
            ipp = 0
            ipstor = mr
            select case (istag)
                case default
                    p(:mr) = b(:mr)
                    b(:mr) = b(:mr) + q(:mr, n)
                    tcos(1) = ONE
                    tcos(2) = ZERO
                    call self%solve_tridiag(1, 1, mr, a, bb, c, b, tcos, d, w)
                    q(:mr, j) = q(:mr, jm2) + p(:mr) + b(:mr)
                    goto 150
                case (1)
                    p(:mr) = b(:mr)
                    q(:mr, j) = q(:mr, jm2) + TWO*q(:mr, jp2) + 3.0_wp*b(:mr)
                    goto 150
            end select
        end if

        b(:mr) = q(:mr, j) + HALF *(q(:mr, jm2)-q(:mr, jm1)-q(:mr, jm3))

        if (nrodpr == 0) then
            b(:mr) = b(:mr) + p(ipp+1:mr+ipp)
        else
            b(:mr) = b(:mr) + q(:mr, jp2) - q(:mr, jp1)
        end if

        call self%solve_tridiag(i2r, 0, mr, a, bb, c, b, tcos, d, w)
        ipp = ipp + mr
        ipstor = max(ipstor, ipp + mr)
        p(ipp+1:mr+ipp) = b(:mr) + HALF*(q(:mr, j)-q(:mr, jm1)-q(:mr, jp1))
        b(:mr) = p(ipp+1:mr+ipp) + q(:mr, jp2)

        if (lr /= 0) then
            call self%generate_cosines(lr, 1, HALF, fden, tcos(i2r+1:))
            call self%merge_cosines(tcos, 0, i2r, i2r, lr, kr)
        else
            do i = 1, i2r
                ii = kr + i
                tcos(ii) = tcos(i)
            end do
        end if

        call self%generate_cosines(kr, 1, HALF, fden, tcos)

        if (lr == 0) then
            select case (istag)
                case (1)
                    goto 146
                case (2)
                    goto 145
            end select
        end if

145 continue

    call self%solve_tridiag(kr, kr, mr, a, bb, c, b, tcos, d, w)
    goto 148

146 continue

    b(:mr) = fistag*b(:mr)

148 continue

    q(:mr, j) = q(:mr, jm2) + p(ipp+1:mr+ipp) + b(:mr)

150 continue
    lr = kr
    kr = kr + jr
end if

select case (mixbnd)
    case default

        nr = (nlast - 1)/jr + 1

        if (nr <= 3) then
            goto 155
        end if
    case (2)

        nr = nlast/jr

        if (nr <= 1) then
            goto 192
        end if
end select

i2r = jr
nrodpr = nrod

goto 104

155 continue

    j = 1 + jr
    jm1 = j - i2r
    jp1 = j + i2r
    jm2 = nlast - i2r

    if (nr /= 2) then
        if (lr /= 0) then
            goto 170
        end if

        if (n == 3) then
            !
            !     case n = 3.
            !
            select case (istag)
                case (1)
                    goto 156
                case (2)
                    goto 168
            end select

156     continue

        b(:mr) = q(:mr, 2)
        tcos(1) = ZERO

        call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)

        q(:mr, 2) = b(:mr)
        b(:mr) = 4.0_wp*b(:mr) + q(:mr, 1) + TWO*q(:mr, 3)
        tcos(1) = -TWO
        tcos(2) = TWO
        i1 = 2
        i2 = 0

        call self%solve_tridiag(i1, i2, mr, a, bb, c, b, tcos, d, w)

        q(:mr, 2) = q(:mr, 2) + b(:mr)
        b(:mr) = q(:mr, 1) + TWO*q(:mr, 2)
        tcos(1) = ZERO

        call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)

        q(:mr, 1) = b(:mr)
        jr = 1
        i2r = 0
        goto 194
    end if
    !
    ! case n = 2**p+1
    !
    select case (istag)
        case (1)
            goto 162
        case (2)
            goto 170
    end select

162 continue

    b(:mr) = &
        q(:mr, j) + HALF*q(:mr, 1) &
        - q(:mr, jm1) + q(:mr, nlast) - &
        q(:mr, jm2)

    call self%generate_cosines(jr, 1, HALF, ZERO, tcos)

    call self%solve_tridiag(jr, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, j) = HALF*(q(:mr, j)-q(:mr, jm1)-q(:mr, jp1)) + b(:mr)

    b(:mr) = q(:mr, 1) + TWO*q(:mr, nlast) + 4.0_wp*q(:mr, j)

    jr2 = 2*jr

    call self%generate_cosines(jr, 1, ZERO, ZERO, tcos)

    tcos(jr+1:jr*2) = -tcos(jr:1:(-1))

    call self%solve_tridiag(jr2, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, j) = q(:mr, j) + b(:mr)
    b(:mr) = q(:mr, 1) + TWO*q(:mr, j)

    call self%generate_cosines(jr, 1, HALF, ZERO, tcos)

    call self%solve_tridiag(jr, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, 1) = HALF*q(:mr, 1) - q(:mr, jm1) + b(:mr)

    goto 194
!
! case of general n with nr = 3 .
!
168 continue

    b(:mr) = q(:mr, 2)
    q(:mr, 2) = ZERO
    b2(:mr) = q(:mr, 3)
    b3(:mr) = q(:mr, 1)
    jr = 1
    i2r = 0
    j = 2

    goto 177

170 continue

    b(:mr) = HALF*q(:mr, 1) - q(:mr, jm1) + q(:mr, j)

    if (nrod == 0) then
        b(:mr) = b(:mr) + p(ipp+1:mr+ipp)
    else
        b(:mr) = b(:mr) + q(:mr, nlast) - q(:mr, jm2)
    end if

    do i = 1, mr
        t = HALF*(q(i, j)-q(i, jm1)-q(i, jp1))
        q(i, j) = t
        b2(i) = q(i, nlast) + t
        b3(i) = q(i, 1) + TWO*t
    end do

177 continue

    k1 = kr + 2*jr - 1
    k2 = kr + jr
    tcos(k1+1) = -2.
    k4 = k1 + 3 - istag

    call self%generate_cosines(k2 + istag - 2, 1, ZERO, fnum, tcos(k4:))

    k4 = k1 + k2 + 1

    call self%generate_cosines(jr - 1, 1, ZERO, ONE, tcos(k4:))
    call self%merge_cosines(tcos, k1, k2, k1 + k2, jr - 1, 0)

    k3 = k1 + k2 + lr

    call self%generate_cosines(jr, 1, HALF, ZERO, tcos(k3+1:))

    k4 = k3 + jr + 1

    call self%generate_cosines(kr, 1, HALF, fden, tcos(k4:))
    call self%merge_cosines(tcos, k3, jr, k3 + jr, kr, k1)

    if (lr /= 0) then
        call self%generate_cosines(lr, 1, HALF, fden, tcos(k4:))
        call self%merge_cosines(tcos, k3, jr, k3 + jr, lr, k3 - lr)
        call self%generate_cosines(kr, 1, HALF, fden, tcos(k4:))
    end if

    k3 = kr
    k4 = kr

    call self%solve_tridiag3(mr, a, bb, c, k, b, b2, b3, tcos, d, w, w2, w3)

    b(:mr) = b(:mr) + b2(:mr) + b3(:mr)
    tcos(1) = TWO

    call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, j) = q(:mr, j) + b(:mr)
    b(:mr) = q(:mr, 1) + TWO*q(:mr, j)

    call self%generate_cosines(jr, 1, HALF, ZERO, tcos)
    call self%solve_tridiag(jr, 0, mr, a, bb, c, b, tcos, d, w)

    if (jr == 1) then
        q(:mr, 1) = b(:mr)
        goto 194
    end if

    q(:mr, 1) = HALF*q(:mr, 1) - q(:mr, jm1) + b(:mr)
    goto 194
end if

if (n == 2) then
    !
    ! case  n = 2
    !
    b(:mr) = q(:mr, 1)
    tcos(1) = ZERO

    call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, 1) = b(:mr)
    b(:mr) = TWO *(q(:mr, 2)+b(:mr))*fistag
    tcos(1) = -fistag
    tcos(2) = TWO

    call self%solve_tridiag(2, 0, mr, a, bb, c, b, tcos, d, w)

    q(:mr, 1) = q(:mr, 1) + b(:mr)
    jr = 1
    i2r = 0
    goto 194
end if

b3(:mr) = ZERO
b(:mr) = q(:mr, 1) + TWO *p(ipp+1:mr+ipp)
q(:mr, 1) = HALF *q(:mr, 1) - q(:mr, jm1)
b2(:mr) = TWO *(q(:mr, 1)+q(:mr, nlast))
k1 = kr + jr - 1
tcos(k1+1) = -2.
k4 = k1 + 3 - istag

call self%generate_cosines(kr + istag - 2, 1, ZERO, fnum, tcos(k4:))

k4 = k1 + kr + 1

call self%generate_cosines(jr - 1, 1, ZERO, ONE, tcos(k4:))
call self%merge_cosines(tcos, k1, kr, k1 + kr, jr - 1, 0)
call self%generate_cosines(kr, 1, HALF, fden, tcos(k1+1:))

k2 = kr
k4 = k1 + k2 + 1

call self%generate_cosines(lr, 1, HALF, fden, tcos(k4:))

k3 = lr
k4 = 0

call self%solve_tridiag3(mr, a, bb, c, k, b, b2, b3, tcos, d, w, w2, w3)

b(:mr) = b(:mr) + b2(:mr)
tcos(1) = TWO

call self%solve_tridiag(1, 0, mr, a, bb, c, b, tcos, d, w)

q(:mr, 1) = q(:mr, 1) + b(:mr)
goto 194

192 continue

    b(:mr) = q(:mr, nlast)
    goto 196

194 continue

    j = nlast - jr
    b(:mr) = q(:mr, nlast) + q(:mr, j)

196 continue

    jm2 = nlast - i2r

    if (jr == 1) then
        q(:mr, nlast) = ZERO
    else
        if (nrod == 0) then
            q(:mr, nlast) = p(ipp+1:mr+ipp)
            ipp = ipp - mr
        else
            q(:mr, nlast) = q(:mr, nlast) - q(:mr, jm2)
        end if
    end if
    call self%generate_cosines(kr, 1, HALF, fden, tcos)
    call self%generate_cosines(lr, 1, HALF, fden, tcos(kr+1:))

    if (lr == 0) then
        b(:mr) = fistag*b(:mr)
    end if

    call self%solve_tridiag(kr, lr, mr, a, bb, c, b, tcos, d, w)

    q(:mr, nlast) = q(:mr, nlast) + b(:mr)
    nlastp = nlast

206 continue

    jstep = jr
    jr = i2r
    i2r = i2r/2

    if (jr == 0) then
        w(1) = ipstor
        return
    end if

    select case (mixbnd)
        case (2)
            jstart = jr
        case default
            jstart = 1 + jr
    end select

    kr = kr - jr

    if (nlast + jr <= n) then
        kr = kr - jr
        nlast = nlast + jr
        jstop = nlast - jstep
    else
        jstop = nlast - jr
    end if

    lr = kr - jr
    call self%generate_cosines(jr, 1, HALF, ZERO, tcos)

    do j = jstart, jstop, jstep
        jm2 = j - jr
        jp2 = j + jr

        if (j == jr) then
            b(:mr) = q(:mr, j) + q(:mr, jp2)
        else
            b(:mr) = q(:mr, j) + q(:mr, jm2) + q(:mr, jp2)
        end if

        if (jr == 1) then
            q(:mr, j) = ZERO
        else
            jm1 = j - i2r
            jp1 = j + i2r
            q(:mr, j) = HALF*(q(:mr, j)-q(:mr, jm1)-q(:mr, jp1))
        end if

        call self%solve_tridiag(jr, 0, mr, a, bb, c, b, tcos, d, w)
        q(:mr, j) = q(:mr, j) + b(:mr)
    end do

    nrod = 1
    if (nlast + i2r <= n) then
        nrod = 0
    end if

    if (nlastp /= nlast) then
        goto 194
    end if

    goto 206

    w(1) = ipstor

end associate

end subroutine genbun_solve_poisson_neumann

end module type_CenteredCyclicReductionUtility


include "remap_utils.f90"

subroutine remap_1d_grid2grid(x1min, x1max, grid1, x2min, x2max, grid2, pixlen, f1, f2)

  ! Remaps field 1 onto field 2 using exact weights.
  !
  ! Parameters
  ! ----------
  ! x1min : float
  !   Minimum in grid 1.
  ! x1max : float
  !   Maximum in grid 1.
  ! grid1 : int
  !   Number of grid points in grid 1.
  ! x2min : float
  !   Minimum in grid 2.
  ! x2max : float
  !   Maximum in grid 2.
  ! grid2 : int
  !   Number of grid points in grid 2.
  ! pixlen : int
  !   Length of pixel mapping indices and weights.
  ! f1 : array
  !   Values on grid 1.
  !
  ! Returns
  ! -------
  ! f2 : array
  !   Remapped field 1 onto field 2.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: grid1, grid2, pixlen
  real(kind=dp), intent(in) :: x1min, x1max, x2min, x2max, f1(grid1)
  real(kind=dp), intent(out) :: f2(grid2)
  real(kind=dp) :: weights(pixlen)
  integer :: pix(pixlen), i, j, which2pix

  ! Function

  do i = 1, grid2

    which2pix = i-1

    call remap_1d_grid2grid_pixel(x1min, x1max, grid1, x2min, x2max, grid2, which2pix, pixlen, pix, weights)

    f2(i) = 0.

    do j = 1, pixlen

      if (pix(j) .ne. -1) then
        f2(i) = f2(i) + weights(j)*f1(pix(j)+1)
      end if

    end do

  end do

end subroutine remap_1d_grid2grid


   PROGRAM value_delta_R
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=27
   INTEGER (KIND=8):: i
   REAL    (KIND=8),DIMENSION(n):: ra,rb,R,v,pa,dev,delta_R

!!!=======================================================================================
!!!=======================================================================================

   OPEN(unit=11,file='average_Q005_L12.txt')
   OPEN(unit=12,file='delta_R_Q005_L12.txt')

   DO i=1,n
      READ(11,*)pa(i),ra(i),rb(i),R(i),v(i),dev(i)
   END DO

   delta_R(:)=0.
   DO i=1,n-1
      delta_R(i)=(R(i+1)-R(i))/(pa(i+1)-pa(i))
   END DO

   DO i=1,n
      WRITE(12,*)pa(i),delta_R(i)
   END DO

   CLOSE(11)
   CLOSE(12)

   END PROGRAM value_delta_R


C$Procedure  DP2HX  ( D.p. number to hexadecimal string )

      SUBROUTINE DP2HX ( NUMBER, STRING, LENGTH )

C$ Abstract
C
C     Convert a double precision number to an equivalent character
C     string using a base 16 ``scientific notation.''
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     ALPHANUMERIC
C     CONVERSION
C
C$ Declarations

      DOUBLE PRECISION      NUMBER
      CHARACTER*(*)         STRING
      INTEGER               LENGTH

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     NUMBER     I   D.p. number to be converted.
C     STRING     O   Equivalent character string, left justified.
C     LENGTH     O   Length of the character string produced.
C
C$ Detailed_Input
C
C     NUMBER   The double precision number to be converted to a
C              character string representation.
C
C$ Detailed_Output
C
C     STRING   The character string produced by this routine which
C              represents NUMBER in a base 16 ``scientific notation,''
C              e.g.:
C
C                 672.0 = '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3
C
C              and
C
C                 -11.0 = '-B^1' = - ( 11/16 ) * 16**1.
C
C              The following table describes the character set used to
C              represent the hexadecimal digits and their corresponding
C              values.
C
C                   Character    Value         Character    Value
C                   ---------    ------        ---------    ------
C                     '0'         0.0D0          '8'         8.0D0
C                     '1'         1.0D0          '9'         9.0D0
C                     '2'         2.0D0          'A'        10.0D0
C                     '3'         3.0D0          'B'        11.0D0
C                     '4'         4.0D0          'C'        12.0D0
C                     '5'         5.0D0          'D'        13.0D0
C                     '6'         6.0D0          'E'        14.0D0
C                     '7'         7.0D0          'F'        15.0D0
C
C              The carat, or hat, character, '^', is used to
C              distinguish the exponent.
C
C              The plus sign, '+', and the minus sign, '-', are used,
C              and they have their usual meanings.
C
C              In order to obtain the entire character string produced
C              by this routine, the output character string should be
C              at least N characters long, where
C
C
C                        # of bits per double precision mantissa + 3
C              N = 3 + ----------------------------------------------
C                                            4
C
C                        # of bits per double precision exponent + 3
C                    + ---------------------------------------------- .
C                                            4
C
C              There should be one character position for the sign of
C              the mantissa, one for the sign of the exponent, one for
C              the exponentiation character, and one for each
C              hexadecimal digit that could be produced from a mantissa
C              and an exponent.
C
C              The following table contains minimum output string
C              lengths necessary to obtain the complete character
C              string produced by this routine for some typical
C              implementations of double precision numbers.
C
C              Double precision number
C              Size Mantissa Exponent    Minimum output string length
C              bits   bits     bits
C              ---- -------- --------    ----------------------------
C              64   48       15          3 + 12 + 4 = 19
C              64   55+1     8           3 + 14 + 2 = 19 (VAX)
C              64   52       11          3 + 13 + 3 = 19 (IEEE)
C
C              The base 16 ``scientific notation'' character string
C              produced by this routine will be left justified and
C              consist of a contiguous sequence of characters with one
C              of following formats:
C
C                  (1)   h h h h  ... h ^H H  ... H
C                         1 2 3 4      n  1 2      m
C
C                  (2)   -h h h h  ... h ^H H  ... H
C                          1 2 3 4      n  1 2      m
C
C                  (3)   h h h h  ... h ^-H H  ... H
C                         1 2 3 4      n   1 2      m
C
C                  (4)   -h h h h  ... h ^-H H  ... H
C                          1 2 3 4      n   1 2      m
C
C              where
C
C                 h   and  H   denote hexadecimal digits
C                  i        j
C
C                 '^'          denotes exponentiation ( base 16 )
C
C              and
C
C                 '+' and '-'  have their usual interpretations.
C
C              The character string produced will be blank padded on
C              the right if LENGTH < LEN( STRING ).
C
C     LENGTH   Length of the base 16 ``scientific notation'' character
C              string produced by this routine.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)   If the output character string is not long enough to
C          contain the entire character string that was produced,
C          the string will be truncated on the right.
C
C     2)   If LEN( STRING ) > LENGTH, the output character string will
C          be blank padded on the right.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine converts a double precision number into an equivalent
C     character string using a base 16 ``scientific notation.'' This
C     representation allows the full precision of a number to be placed
C     in a format that is suitable for porting or archival storage.
C
C     This routine is one of a pair of routines which are used to
C     perform conversions between double precision numbers and
C     an equivalent base 16 ``scientific notation'' character string
C     representation:
C
C           DP2HX  -- Convert a double precision number into a base 16
C                     ``scientific notation'' character string.
C
C           HX2DP  -- Convert a base 16 ``scientific notation''
C                     character string into a double precision number.
C
C$ Examples
C
C     The following input and output argument values illustrate the
C     action of DP2HX for various input values of NUMBER.
C
C     Note: The hat or carat, '^', signals an exponent.
C
C         NUMBER             STRING                         LENGTH
C         -----------------  -----------------------------  ------
C              2.0D-9         89705F4136B4A6^-7             17
C              1.0D0          1^1                           3
C             -1.0D0         -1^1                           4
C           1024.0D0          4^3                           3
C          -1024.0D0         -4^3                           4
C         521707.0D0          7F5EB^5                       7
C             27.0D0          1B^2                          4
C              0.0D0          0^0                           3
C
C$ Restrictions
C
C     The maximum number of characters permitted in the output string
C     is specified by the local parameter STRLEN.
C
C$ Author_and_Institution
C
C     K.R. Gehringer   (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1994 (KRG)
C
C        Fixed a typo in the description of the input argument STRING.
C        The example showing the expansion of 160 into hexadecimal
C        was incorrect. 160 was replaced with 672 which makes the
C        example correct.
C
C-    SPICELIB Version 1.0.0, 26-OCT-1992 (KRG)
C
C-&

C$ Index_Entries
C
C     convert d.p. to signed normalized hexadecimal string
C     convert d.p. number to encoded d.p. number
C     convert d.p. to base 16 scientific notation
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.0.1, 10-MAR-1994 (KRG)
C
C        Fixed a typo in the description of the input argument STRING.
C        The example showing the expansion of 160 into hexadecimal
C        was incorrect. 160 was replaced with 672 which makes the
C        example correct.
C
C        Old Example:
C
C           160.0 = '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3
C
C        New Example:
C
C           672.0 = '2A^3' = ( 2/16 + 10/( 16**2 ) ) * 16**3
C
C-&

C
C     Local Parameters
C
      CHARACTER*(1)         EXPCHR
      PARAMETER           ( EXPCHR = '^')

      DOUBLE PRECISION      BASE
      PARAMETER           ( BASE = 16.0D0 )

      DOUBLE PRECISION      INVBAS
      PARAMETER           ( INVBAS = 1.0D0/BASE )

      INTEGER               EXPINB
      PARAMETER           ( EXPINB = 1 )

      DOUBLE PRECISION      FACTR1
      PARAMETER           ( FACTR1 = 4294967296.0D0 )

      DOUBLE PRECISION      INVFC1
      PARAMETER           ( INVFC1 = 1.0D0/FACTR1 )

      INTEGER               EXPIN1
      PARAMETER           ( EXPIN1 = 8 )

      DOUBLE PRECISION      FACTR2
      PARAMETER           ( FACTR2 = 65536.0D0 )

      DOUBLE PRECISION      INVFC2
      PARAMETER           ( INVFC2 = 1.0D0/FACTR2 )

      INTEGER               EXPIN2
      PARAMETER           ( EXPIN2 = 4 )

      INTEGER               STRLEN
      PARAMETER           ( STRLEN = 255 )

      INTEGER               MAXDIG
      PARAMETER           ( MAXDIG = 16 )
C
C     Local variables
C
      CHARACTER*(1)         DIGITS(0:MAXDIG-1)
      CHARACTER*(STRLEN)    EXPSTR
      CHARACTER*(STRLEN)    TMPSTR

      DOUBLE PRECISION      REMNDR
      DOUBLE PRECISION      TMPNUM

      INTEGER               EXPLEN
      INTEGER               INTEXP
      INTEGER               POSITN
      INTEGER               RESULT

      LOGICAL               NEGTIV
      LOGICAL               POSTIV
C
C     Saved variables
C
      SAVE                  DIGITS
C
C     Initial values
C
      DATA                  DIGITS /
     .                               '0', '1', '2', '3',
     .                               '4', '5', '6', '7',
     .                               '8', '9', 'A', 'B',
     .                               'C', 'D', 'E', 'F'
     .                             /

C
C     Make a copy of the input so that it will not be changed by this
C     routine. Also, assume that we do not know the sign of the number.
C
      TMPNUM = NUMBER
      NEGTIV = .FALSE.
      POSTIV = .FALSE.
C
C     Check to see what the sign of the number is, because we treat
C     negative numbers, positive numbers and zero separately. This
C     simplifies the testing in the loop boundaries a bit, and removes
C     calls to DABS() that would otherwise have been necessary.
C
C     Set the appropriate logical flag for the sign of the input number.
C
      IF ( TMPNUM .LT. 0.0D0 ) THEN

         NEGTIV = .TRUE.

      ELSE IF ( TMPNUM .GT. 0.0D0 ) THEN

         POSTIV = .TRUE.

      END IF
C
C     If nonzero, a double precision number is first normalized,
C     so that it has a value between 1.0D0/BASE and 1.0D0 or -1.0D0
C     and -1/BASE. The hexadecimal digits in the mantissa  are found
C     by repeated applications of multiplication and truncation
C     operations. The hexadecimal digits will be in the correct order
C     when finished. The string will be left justified, and its length
C     will be set before returning.
C
C     Calculate the exponent of the number using multiple scaling
C     levels. The different scale factors, 16**8, 16**4, and 16,
C     provide a significant speed improvement for the normalization
C     process.
C
      INTEXP = 0
      IF ( NEGTIV ) THEN

         IF ( TMPNUM .GT. -1.0D0 ) THEN
C
C           ABS(TMPNUM) .LT. 1.0
C
            DO WHILE ( FACTR1 * TMPNUM .GT. -1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * FACTR1
               INTEXP = INTEXP - EXPIN1

            END DO

            DO WHILE ( FACTR2 * TMPNUM .GT. -1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * FACTR2
               INTEXP = INTEXP - EXPIN2

            END DO

            DO WHILE ( ( BASE * TMPNUM ) .GT. -1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * BASE
               INTEXP = INTEXP - EXPINB

            END DO
C
C           At this point, -1 < TMPNUM <= -1/BASE.
C
         ELSE
C
C           ABS(TMPNUM) .GE. 1.0
C
            DO WHILE ( INVFC1 * TMPNUM .LE. -1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVFC1
               INTEXP = INTEXP + EXPIN1

            END DO

            DO WHILE ( INVFC2 * TMPNUM .LE. -1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVFC2
               INTEXP = INTEXP + EXPIN2

            END DO

            DO WHILE ( TMPNUM .LE. -1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVBAS
               INTEXP = INTEXP + EXPINB

            END DO
C
C           At this point, -1 < TMPNUM <= -1/BASE.
C
         END IF

      ELSE IF ( POSTIV ) THEN

         IF ( TMPNUM .LT. 1.0D0 ) THEN
C
C           ABS(TMPNUM) .LT. 1.0
C
            DO WHILE ( FACTR1 * TMPNUM .LT. 1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * FACTR1
               INTEXP = INTEXP - EXPIN1

            END DO

            DO WHILE ( FACTR2 * TMPNUM .LT. 1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * FACTR2
               INTEXP = INTEXP - EXPIN2

            END DO

            DO WHILE ( ( BASE * TMPNUM ) .LT. 1.0D0 )
C
C              Scale the number and decrement the exponent.
C
               TMPNUM = TMPNUM * BASE
               INTEXP = INTEXP - EXPINB

            END DO
C
C           At this point, 1/BASE <= TMPNUM < 1
C
         ELSE
C
C           ABS(TMPNUM) .GE. 1.0
C
            DO WHILE ( INVFC1 * TMPNUM .GE. 1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVFC1
               INTEXP = INTEXP + EXPIN1

            END DO

            DO WHILE ( INVFC2 * TMPNUM .GE. 1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVFC2
               INTEXP = INTEXP + EXPIN2

            END DO

            DO WHILE ( TMPNUM .GE. 1.0D0 )
C
C              Scale the number and increment the exponent.
C
               TMPNUM = TMPNUM * INVBAS
               INTEXP = INTEXP + EXPINB

            END DO
C
C           At this point, 1/BASE <= TMPNUM < 1
C
         END IF

      END IF
C
C     We do different things for the cases where the number to be
C     converted is positive, negative, or zero.
C
      IF ( NEGTIV ) THEN
C
C        Set the beginning position.
C
         POSITN = 1
C
C        Put the minus sign in place.
C
         TMPSTR(POSITN:POSITN) = '-'
C
C        Start with the remainder equal to the normalized value of the
C        original number.
C
         REMNDR = TMPNUM
C
C        Collect all of the digits in the string.
C
C        This stopping test works because the base is a power of
C        2 and the mantissa is composed of a sum of powers of 2.
C
         DO WHILE ( REMNDR .NE. 0.0D0 )
C
C           -1 < REMNDR <= -1/BASE
C
            POSITN                 = POSITN + 1
            TMPNUM                 = REMNDR * BASE
            RESULT                 = INT( TMPNUM )
            REMNDR                 = TMPNUM - DBLE( RESULT )
            TMPSTR (POSITN:POSITN) = DIGITS(-RESULT)

         END DO
C
C        Put the exponent on the end of the number and update the
C        position.
C
         CALL INT2HX( INTEXP, EXPSTR, EXPLEN )
         TMPSTR(POSITN+1:) = EXPCHR//EXPSTR(1:EXPLEN)
         POSITN            = POSITN + EXPLEN + 1

      ELSE IF ( POSTIV ) THEN
C
C        Set the beginning position.
C
         POSITN = 0
C
C        Start with the remainder equal to the normalized value of the
C        original number.
C
         REMNDR = TMPNUM
C
C        Collect all of the digits in the string.
C
C        This stopping test works because the base is a power of
C        2 and the mantissa is composed of a sum of powers of 2.
C
         DO WHILE ( REMNDR .NE. 0.0D0 )
C
C           1/BASE <= REMNDR < 1
C
            POSITN                 = POSITN + 1
            TMPNUM                 = REMNDR * BASE
            RESULT                 = INT( TMPNUM )
            REMNDR                 = TMPNUM - DBLE( RESULT )
            TMPSTR (POSITN:POSITN) = DIGITS(RESULT)

         END DO
C
C        Put the exponent on the end of the number and update the
C        position.
C
         CALL INT2HX( INTEXP, EXPSTR, EXPLEN )
         TMPSTR(POSITN+1:) = EXPCHR//EXPSTR(1:EXPLEN)
         POSITN            = POSITN + EXPLEN + 1

      ELSE
C
C        Treat zero as a special case, because it's easier.
C
         POSITN      = 3
         TMPSTR(1:3) = '0^0'

      END IF
C
C     Set the value for the length of the character string produced
C     before returning.
C
      LENGTH = POSITN
C
C     Set the value of the output string before returning. Let the
C     Fortran string assignment deal with the left justification, and
C     the truncation on the right if STRING is not long enough to
C     contain all of the characters produced.
C
      STRING = TMPSTR(:LENGTH)

      RETURN
      END


subroutine solve_backward_euler_system(t, dt, iterate, d_iterate, residual_norm)

! Solve the Netwon system,
!     newton_operator(d_iterate) = newton_rhs,
! using BiCGStab.
!
! The implementation is taken from Algorithm 7.7 of Y. Saad, Iterative Methods
! for Sparse Linear Systems, 2nd Ed.
!
! Args:
!   t: Time at beginning of the current step.
!   dt: Length of the current time step.
!   iterate: The current Newton iterate.
!   d_iterate: iterate + d_iterate will yield the next Newton iterate.
!     Stores newton_rhs on input.
!   residual_norm: Returns final norm of the residual

! TODO: Make max_iter a global parameter?

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision :: cg_tolerance
    integer :: cg_verbosity
    common /cg_config/ cg_tolerance, cg_verbosity

    double precision, intent(in) :: t, dt
    double precision, intent(in), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: iterate
    double precision, intent(inout), dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: d_iterate
    double precision, intent(out) :: residual_norm

    integer :: max_iter, iter, ix, iy, ieqn
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: r, r_star, p, s, Ap, As
    double precision :: alpha, omega, beta, r_dot_r_star, r_dot_r_star_old
    double precision, external :: inner_product
    double precision :: denominator

    max_iter = 10 * mx * my

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1, mx
                r(ix, iy, ieqn) = d_iterate(ix, iy, ieqn)
                r_star(ix, iy, ieqn) = r(ix, iy, ieqn)
                p(ix, iy, ieqn) = r(ix, iy, ieqn)
                d_iterate(ix, iy, ieqn) = 0.d0
            end do
        end do
    end do
    r_dot_r_star = inner_product(r, r_star)
    residual_norm = sqrt(r_dot_r_star)  ! Using r_star = r

    if (residual_norm <= cg_tolerance) then
        if (cg_verbosity > 0) then
            print '(AE16.10)', 'BiCGStab finished without iterating; residual_norm = ', residual_norm
        end if
        return
    end if

    do iter = 1, max_iter
        call get_backward_euler_lhs(t, dt, iterate, p, Ap)
        denominator = inner_product(Ap, r_star)
        alpha = inner_product(r, r_star) / denominator

        ! TODO: Not sure if this is reasonable.
        if (denominator == 0.d0 .or. alpha == 0.d0) then
            if (cg_verbosity > 0) then
                print '(A,A,E16.10,A)', 'BiCGStab reached degenerate condition, ',  &
                    '.  Terminating with residual_norm = ', residual_norm, '.'
            end if
            return
        end if

        do ieqn = 1, meqn
            !$omp parallel do private(ix)
            do iy = 1, my
                do ix = 1, mx
                    s(ix, iy, ieqn) = r(ix, iy, ieqn) - alpha * Ap(ix, iy, ieqn)
                end do
            end do
        end do

        call get_backward_euler_lhs(t, dt, iterate, s, As)
        omega = inner_product(As, s) / inner_product(As, As)
        do ieqn = 1, meqn
            !$omp parallel do private(ix)
            do iy = 1, my
                do ix = 1, mx
                    d_iterate(ix, iy, ieqn) = d_iterate(ix, iy, ieqn) +  &
                        alpha * p(ix, iy, ieqn) + omega * s(ix, iy, ieqn)
                    r(ix, iy, ieqn) = s(ix, iy, ieqn) - omega * As(ix, iy, ieqn)
                end do
            end do
        end do

        residual_norm = sqrt(inner_product(r, r))
        if (residual_norm <= cg_tolerance) then
            if (cg_verbosity > 0) then
                print '(A,I5,A,E16.10)', 'BiCGStab completed after ', iter,  &
                    ' iterations with norm(residual) = ', residual_norm
            end if
            return
        end if

        r_dot_r_star_old = r_dot_r_star
        r_dot_r_star = inner_product(r, r_star)

        beta = r_dot_r_star / r_dot_r_star_old * alpha / omega

        do ieqn = 1, meqn
            !$omp parallel do private(ix)
            do iy = 1, my
                do ix = 1, mx
                    p(ix, iy, ieqn) = r(ix, iy, ieqn) + beta * (p(ix, iy, ieqn) -  &
                        omega * Ap(ix, iy, ieqn))
                end do
            end do
        end do

        if (cg_verbosity > 1) then
            print '(A,I4,A,E16.10)', 'Iteration ', iter, ': residual_norm = ',  &
                residual_norm
        end if
    end do

    if (cg_verbosity > 0) then
        print '(A,I5,A,E16.10)', 'BiCGStab failed to converge after ', iter-1,  &
            'iterations.  Final residual_norm: ', residual_norm, '.'
    end if

end subroutine solve_backward_euler_system


      PROGRAM shallow

!     BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE
!     PREFORMANCE OF CURRENT SUPERCOMPUTERS. THE MODEL IS
!     BASED OF THE PAPER - THE DYNAMICS OF FINITE-DIFFERENCE
!     MODELS OF THE SHALLOW-WATER EQUATIONS, BY ROBERT SADOURNY
!     J. ATM. SCIENCES, VOL 32, NO 4, APRIL 1975.
!
!     CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR
!     ATMOSPHERIC RESEARCH, BOULDER, CO,  OCTOBER 1984.
!     Modified by Juliana Rew, NCAR, January 2006
!
!     In this version, shallow4.f, initial and calculated values
!     of U, V, and P are written to a netCDF file
!     for later use in visualizing the results. The netCDF data
!     management library is freely available from
!     http://www.unidata.ucar.edu/software/netcdf
!     This code is still serial but has been brought up to modern
!     Fortran constructs and uses portable intrinsic Fortran 90 timing routines
!     This can be compiled on the IBM SP using:
!     xlf90 -qmaxmem=-1 -g -o shallow4 -qfixed=132 -qsclk=micro \
!     -I/usr/local/include shallow4.f -L/usr/local/lib32/r4i4 -l netcdf
!     where the -L and -I point to local installation of netCDF
!
!     Changes from shallow4.f (Annette Osprey, January 2010):
!     - Converted to free-form fortran 90.
!     - Some tidying up of old commented-out code.
!     - Explicit type declarations.
!     - Variables n, m, itmax and mprint read in from namelist.
!     - Dynamic array allocation.
!     - Only write to netcdf at mprint timesteps.
!     - Don't write wrap-around points to NetCDF file.
!     - Use 8-byte reals.

      USE dl_timer
      use shallow_io_mod, only: ascii_write
      IMPLICIT NONE

      INTEGER :: m, n    ! global domain size
      INTEGER :: itmax   ! number of timesteps
      INTEGER :: mprint  ! frequency of output
      NAMELIST/global_domain/ m, n, itmax, mprint

      LOGICAL :: l_out   ! produce output
      NAMELIST/io_control/ l_out

      INTEGER :: m_len, n_len       ! array sizes
      INTEGER :: mp1, np1           ! m+1 and n+1

      ! solution arrays
      REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:) ::                &
                             u, v, p, unew, vnew, pnew,           &
                             uold, vold, pold, cu, cv, z, h, psi

      REAL(KIND=8) :: dt, tdt, dx, dy, a, alpha, el, pi, tpi, di, dj, pcf, &
                      tdts8, tdtsdx, tdtsdy, fsdx, fsdy
      INTEGER :: mnmin, ncycle
      INTEGER :: i, j

      ! timer variables
      !REAL(KIND=8) :: mfs100, mfs200, mfs300, mfs310, &
      !                t100, t200, t300, t310,         &
      !                tstart, ctime, tcyc
      !INTEGER :: c1, c2, r, max
      REAL(KIND=8) :: time, ptime

      ! namelist input
      CHARACTER (LEN=8) :: nml_name = "namelist"
      INTEGER :: input_unit = 99
      INTEGER :: ierr

      !> Integer tags for timers
      INTEGER :: idxt0, cu_timer, pbcs_timer, unew_timer, tsmooth_timer

!  ** Initialisations **
      call timer_init()

!     Read in namelist
      OPEN(unit=input_unit, file=nml_name, status='old',iostat=ierr)
      CALL check(ierr, "open "//nml_name)
      READ(unit=input_unit, nml=global_domain, iostat=ierr)
      CALL check(ierr, "read "//nml_name)
      READ(unit=input_unit, nml=io_control, iostat=ierr)
      CALL check(ierr, "read "//nml_name)

      call timer_register(idxt0,     label='Time-stepping', &
                          num_repeats=int(itmax,8))
      call timer_register(cu_timer,  label='Compute CU,CV,CZ,H')
      call timer_register(pbcs_timer,label='PBCs')
      call timer_register(unew_timer,label='Compute {U,V,P}NEW')
      call timer_register(tsmooth_timer,label='Time smooth')

!     Set up arrays
      m_len = m+1
      n_len = n+1

      ALLOCATE( u(m_len,n_len), v(m_len,n_len), p(m_len,n_len) )
      ALLOCATE( unew(m_len,n_len), vnew(m_len,n_len), pnew(m_len,n_len) )
      ALLOCATE( uold(m_len,n_len), vold(m_len,n_len), pold(m_len,n_len) )
      ALLOCATE( cu(m_len,n_len), cv(m_len,n_len) )
      ALLOCATE( z(m_len,n_len), h(m_len,n_len), psi(m_len,n_len) )

!     NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST
!     CYCLE AFTER WHICH IT IS RESET TO DT+DT.
      DT = 90.
      TDT = DT

      DX = 1.0D5
      DY = 1.0D5
      A = 1.0D6
      ALPHA = 0.001d0

      MP1 = M+1
      NP1 = N+1
      EL = N*DX
      PI = 4.0d0*ATAN(1.0d0)
      TPI = PI+PI
      DI = TPI/M
      DJ = TPI/N
      PCF = PI*PI*A*A/(EL*EL)

!     INITIAL VALUES OF THE STREAM FUNCTION AND P
      DO J=1,NP1
         DO I=1,MP1
            PSI(I,J) = A*SIN((I-.5d0)*DI)*SIN((J-.5d0)*DJ)
            P(I,J) = PCF*(COS(2.0d0*(I-1)*DI)   &
                 +COS(2.0d0*(J-1)*DJ))+50000.0d0
         END DO
      END DO

!     INITIALIZE VELOCITIES
      DO J=1,N
         DO I=1,M
            U(I+1,J) = -(PSI(I+1,J+1)-PSI(I+1,J))/DY
            V(I,J+1) = (PSI(I+1,J+1)-PSI(I,J+1))/DX
         END DO
      END DO

!     PERIODIC CONTINUATION
      DO J=1,N
         U(1,J) = U(M+1,J)
         V(M+1,J+1) = V(1,J+1)
      END DO
      DO I=1,M
         U(I+1,N+1) = U(I+1,1)
         V(I,1) = V(I,N+1)
      END DO
      U(1,N+1) = U(M+1,1)
      V(M+1,1) = V(1,N+1)
      DO J=1,NP1
         DO I=1,MP1
            UOLD(I,J) = U(I,J)
            VOLD(I,J) = V(I,J)
            POLD(I,J) = P(I,J)
         END DO
      END DO

!     PRINT INITIAL VALUES
      IF (l_out) THEN
         WRITE(6,390) N,M,DX,DY,DT,ALPHA
 390     FORMAT(" NUMBER OF POINTS IN THE X DIRECTION",I8,/    &
                " NUMBER OF POINTS IN THE Y DIRECTION",I8,/    &
                " GRID SPACING IN THE X DIRECTION    ",F8.0,/  &
                " GRID SPACING IN THE Y DIRECTION    ",F8.0,/  &
                " TIME STEP                          ",F8.0,/  &
                " TIME FILTER PARAMETER              ",F8.3)
         MNMIN = MIN0(M,N)
         !WRITE(6,391) (P(I,I),I=1,MNMIN)
! 391     FORMAT(/' INITIAL DIAGONAL ELEMENTS OF P ' //,(8E15.6))
         !WRITE(6,392) (U(I,I),I=1,MNMIN)
! 392     FORMAT(/' INITIAL DIAGONAL ELEMENTS OF U ' //,(8E15.6))
         !WRITE(6,393) (V(I,I),I=1,MNMIN)
! 393     FORMAT(/' INITIAL DIAGONAL ELEMENTS OF V ' //,(8E15.6))

         ! Generate and output checksums of initial fields
         write(*,"('psi initial CHECKSUM = ',E24.16)") &
              sum( abs(psi(2:m+1,2:n+1)) )
         write(*,"('P initial CHECKSUM = ',E24.16)")   &
              sum( abs(p(1:m,1:n)) )
         write(*,"('U initial CHECKSUM = ',E24.16)")   &
              sum( abs(u(2:M+1,1:N)) )
         write(*,"('V initial CHECKSUM = ',E24.16)")   &
              sum( abs(v(1:m,2:N+1)) )

!        Write intial values of p, u, and v into a netCDF file
         call ascii_write(0,'u_array.dat'  ,u  ,m,n,2,1)
         call ascii_write(0,'cu_array.dat' ,cu ,m,n,2,1)
         call ascii_write(0,'v_array.dat'  ,v  ,m,n,1,2)
         call ascii_write(0,'p_array.dat'  ,p  ,m,n,1,1)
         call ascii_write(0,'psi_array.dat',psi,m,n,2,2)
         call ascii_write(0,'cv_array.dat' ,cv ,m,n,1,2)
      ENDIF

!     Start timer
!      call system_clock (count=c1, count_rate=r, count_max=max)
!      TSTART = c1
!      T300 = 1.
!      T310 = 1.
      TIME = 0.

      !     Start timer
      CALL timer_start(idxt0)

!  ** Start of time loop **
      DO ncycle=1,itmax

!        COMPUTE CAPITAL U, CAPITAL V, Z AND H
         FSDX = 4.0d0/DX
         FSDY = 4.0d0/DY

         !call system_clock(count=c1, count_rate=r,count_max=max)
         !T100 = c1
         CALL timer_start(cu_timer)

         DO J=1,N
            DO I=1,M
               CU(I+1,J) = .5d0*(P(I+1,J)+P(I,J))*U(I+1,J)
               CV(I,J+1) = .5d0*(P(I,J+1)+P(I,J))*V(I,J+1)
               Z(I+1,J+1) =(FSDX*(V(I+1,J+1)-V(I,J+1))-FSDY*(U(I+1,J+1) &
                    -U(I+1,J)))/(P(I,J)+P(I+1,J)+P(I+1,J+1)+P(I,J+1))
               H(I,J) = P(I,J)+0.25d0*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J)  &
                    +V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))
            END DO
         END DO

         CALL timer_stop(cu_timer)
         !call system_clock(count=c2,count_rate=r,count_max=max)
         !T100 = dble(c2-T100)/dble(r)

         CALL timer_start(pbcs_timer)
!        PERIODIC CONTINUATION
         DO J=1,N
            CU(1,J) = CU(M+1,J)
            CV(M+1,J+1) = CV(1,J+1)
            Z(1,J+1) = Z(M+1,J+1)
            H(M+1,J) = H(1,J)
         END DO
         DO I=1,M
            CU(I+1,N+1) = CU(I+1,1)
            CV(I,1) = CV(I,N+1)
            Z(I+1,1) = Z(I+1,N+1)
            H(I,N+1) = H(I,1)
         END DO
         CU(1,N+1) = CU(M+1,1)
         CV(M+1,1) = CV(1,N+1)
         Z(1,1) = Z(M+1,N+1)
         H(M+1,N+1) = H(1,1)

         CALL timer_stop(pbcs_timer)

!        COMPUTE NEW VALUES U,V AND P
         TDTS8 = TDT/8.0d0
         TDTSDX = TDT/DX
         TDTSDY = TDT/DY

         !call system_clock(count=c1, count_rate=r, count_max=max)
         !T200 = c1
         CALL timer_start(unew_timer)

         DO J=1,N
            DO I=1,M
               UNEW(I+1,J) = UOLD(I+1,J)+                                     &
                   TDTS8*(Z(I+1,J+1)+Z(I+1,J))*(CV(I+1,J+1)+CV(I,J+1)+CV(I,J) &
                   +CV(I+1,J))-TDTSDX*(H(I+1,J)-H(I,J))
               VNEW(I,J+1) = VOLD(I,J+1)-TDTS8*(Z(I+1,J+1)+Z(I,J+1)) &
                   *(CU(I+1,J+1)+CU(I,J+1)+CU(I,J)+CU(I+1,J))        &
                   -TDTSDY*(H(I,J+1)-H(I,J))
               PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J))   &
                   -TDTSDY*(CV(I,J+1)-CV(I,J))
            END DO
         END DO

         CALL timer_stop(unew_timer)
         !call system_clock(count=c2, count_rate=r, count_max=max)
         !T200 = dble(c2 -T200)/dble(r)

         CALL timer_start(pbcs_timer)
!        PERIODIC CONTINUATION
         DO J=1,N
            UNEW(1,J) = UNEW(M+1,J)
            VNEW(M+1,J+1) = VNEW(1,J+1)
            PNEW(M+1,J) = PNEW(1,J)
         END DO
         DO I=1,M
            UNEW(I+1,N+1) = UNEW(I+1,1)
            VNEW(I,1) = VNEW(I,N+1)
            PNEW(I,N+1) = PNEW(I,1)
         END DO
         UNEW(1,N+1) = UNEW(M+1,1)
         VNEW(M+1,1) = VNEW(1,N+1)
         PNEW(M+1,N+1) = PNEW(1,1)

         CALL timer_stop(pbcs_timer)

         TIME = TIME + DT

         IF( l_out .AND. (MOD(NCYCLE,MPRINT) .EQ. 0) ) then

            PTIME = TIME/3600.
            WRITE(6,350) NCYCLE,PTIME
 350        FORMAT(//' CYCLE NUMBER',I5,' MODEL TIME IN  HOURS', F6.2)
            !WRITE(6,355) (PNEW(I,I),I=1,MNMIN)
! 355        FORMAT(/' DIAGONAL ELEMENTS OF P ' //(8E15.6))
            !WRITE(6,360) (UNEW(I,I),I=1,MNMIN)
! 360        FORMAT(/' DIAGONAL ELEMENTS OF U ' //(8E15.6))
            !WRITE(6,365) (VNEW(I,I),I=1,MNMIN)
! 365        FORMAT(/' DIAGONAL ELEMENTS OF V ' //(8E15.6))

!           jr added MFS310--don't know what actual mult factor should be
!           jr changed divide by 1 million to divide by 100K since system_clock
!           jr resolution is millisec rather than cpu_time's 10 millisec
            !MFS310 = 0.0
            !MFS100 = 0.0
            !MFS200 = 0.0
            !MFS300 = 0.0
            !IF (T310 .GT. 0) MFS310 = 24.*M*N/T310/1.D5
            !IF (T100 .GT. 0) MFS100 = 24.*M*N/T100/1.D5
            !IF (T200 .GT. 0) MFS200 = 26.*M*N/T200/1.D5
            !IF (T300 .GT. 0) MFS300 = 15.*M*N/T300/1.D5

            !call system_clock(count=c2, count_rate=r,count_max=max)
            !CTIME = dble(c2 - TSTART)/dble(r)
            !TCYC = CTIME/FLOAT(NCYCLE)

            !WRITE(6,375) NCYCLE,CTIME,TCYC,T310,MFS310,T200,MFS200,T300,MFS300
! 375        FORMAT(' CYCLE NUMBER',I5,' TOTAL COMPUTER TIME', D15.6,   &
!                   ' TIME PER CYCLE', D15.6, /                           &
!                   ' TIME AND MEGAFLOPS FOR LOOP 310 ', D15.6,2x,D6.1/   &
!                   ' TIME AND MEGAFLOPS FOR LOOP 200 ', D15.6,2x,D6.1/   &
!                   ' TIME AND MEGAFLOPS FOR LOOP 300 ', D15.6,2x,D6.1/ )

            call ascii_write(ncycle,'u_array.dat'  ,u  ,m,n,2,1)
            call ascii_write(ncycle,'cu_array.dat' ,cu ,m,n,2,1)
            call ascii_write(ncycle,'cv_array.dat' ,cv ,m,n,1,2)
            call ascii_write(ncycle,'v_array.dat'  ,v  ,m,n,1,2)
            call ascii_write(ncycle,'p_array.dat'  ,p  ,m,n,1,1)
            call ascii_write(ncycle,'z_array.dat'  ,z  ,m,n,2,2)
            call ascii_write(ncycle,'h_array.dat'  ,h  ,m,n,1,1)

         endif

!        Write out time if last timestep
!         IF (ncycle .EQ. itmax) THEN
!            call system_clock(count=c2, count_rate=r,count_max=max)
!            CTIME = dble(c2 - TSTART)/dble(r)
!            WRITE(6,376) ctime
! 376        FORMAT('system_clock time ', F15.6)
!         ENDIF

!        TIME SMOOTHING AND UPDATE FOR NEXT CYCLE
         IF(NCYCLE .GT. 1) then

            !call system_clock(count=c1,count_rate=r,count_max=max)
            !T300 = c1
            CALL timer_start(tsmooth_timer)

            DO J=1,N
               DO I=1,M
                  UOLD(I,J) = U(I,J)+ALPHA*(UNEW(I,J)-2.0d0*U(I,J)+UOLD(I,J))
                  VOLD(I,J) = V(I,J)+ALPHA*(VNEW(I,J)-2.0d0*V(I,J)+VOLD(I,J))
                  POLD(I,J) = P(I,J)+ALPHA*(PNEW(I,J)-2.0d0*P(I,J)+POLD(I,J))
                  U(I,J) = UNEW(I,J)
                  V(I,J) = VNEW(I,J)
                  P(I,J) = PNEW(I,J)
               END DO
            END DO

            CALL timer_stop(tsmooth_timer)
            !call system_clock(count=c2,count_rate=r, count_max=max)
            !T300 = dble(c2 - T300)/dble(r)

!           PERIODIC CONTINUATION
            DO J=1,N
               UOLD(M+1,J) = UOLD(1,J)
               VOLD(M+1,J) = VOLD(1,J)
               POLD(M+1,J) = POLD(1,J)
               U(M+1,J) = U(1,J)
               V(M+1,J) = V(1,J)
               P(M+1,J) = P(1,J)
            END DO
            DO I=1,M
               UOLD(I,N+1) = UOLD(I,1)
               VOLD(I,N+1) = VOLD(I,1)
               POLD(I,N+1) = POLD(I,1)
               U(I,N+1) = U(I,1)
               V(I,N+1) = V(I,1)
               P(I,N+1) = P(I,1)
            END DO
            UOLD(M+1,N+1) = UOLD(1,1)
            VOLD(M+1,N+1) = VOLD(1,1)
            POLD(M+1,N+1) = POLD(1,1)
            U(M+1,N+1) = U(1,1)
            V(M+1,N+1) = V(1,1)
            P(M+1,N+1) = P(1,1)
         else

            TDT = TDT+TDT

            !call system_clock(count=c1, count_rate=r,count_max=max)
            !T310 = c1

            DO J=1,NP1
               DO I=1,MP1
                  UOLD(I,J) = U(I,J)
                  VOLD(I,J) = V(I,J)
                  POLD(I,J) = P(I,J)
                  U(I,J) = UNEW(I,J)
                  V(I,J) = VNEW(I,J)
                  P(I,J) = PNEW(I,J)
               END DO
            END DO

            !call system_clock(count=c2, count_rate=r, count_max=max)
            !T310 = dble(c2 - T310)/dble(r)

         endif

     End do

!  ** End of time loop **
      CALL timer_stop(idxt0)

      WRITE(6,"('P CHECKSUM after ',I6,' steps = ',E24.16)") &
           itmax, SUM( ABS(PNEW(1:m,1:n)) )
      WRITE(6,"('U CHECKSUM after ',I6,' steps = ',E24.16)") &
           itmax, SUM( ABS(UNEW(2:M+1,1:N)) )
      WRITE(6,"('V CHECKSUM after ',I6,' steps = ',E24.16)") &
           itmax, SUM( ABS(VNEW(1:m,2:N+1)) )

      CALL timer_report()

!     Free memory
      DEALLOCATE( u, v, p, unew, vnew, pnew, uold, vold, pold )
      DEALLOCATE( cu, cv, z, h, psi )

      END PROGRAM shallow

!     Check error code
      subroutine check(status, text)
      implicit none

      integer, intent(in) :: status
      character (len=*)   :: text

      if (status /= 0) then
        write(6,*) "error ", status
        write(6,*) text
        stop 2
      endif

      end subroutine check