!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(colatitudinal_derivative_routines) colatitudinal_derivative_regular_grid

contains
    !     subroutine vtsec(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
    !                      mdab, ndab, wvts, ierror)
    !
    !     given the vector harmonic analysis br, bi, cr, and ci (computed
    !     by subroutine vhaec) of some vector function (v, w), this
    !     subroutine computes the vector function (vt, wt) which is
    !     the derivative of (v, w) with respect to colatitude theta. vtsec
    !     is similar to vhsec except the vector harmonics are replaced by
    !     their derivative with respect to colatitude with the result that
    !     (vt, wt) is computed instead of (v, w). vt(i, j) is the derivative
    !     of the colatitudinal component v(i, j) at the point theta(i) =
    !     (i-1)*pi/(nlat-1) and longitude phi(j) = (j-1)*2*pi/nlon. the
    !     spectral representation of (vt, wt) is given below at output
    !     parameters vt, wt.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     ityp   = 0  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere. i.e. the arrays
    !                 vt(i, j), wt(i, j) are computed for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !            = 1  no symmetries exist about the equator however the
    !                 the coefficients cr and ci are zero. the synthesis
    !                 is performed on the entire sphere.  i.e. the arrays
    !                 vt(i, j), wt(i, j) are computed for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !            = 2  no symmetries exist about the equator however the
    !                 the coefficients br and bi are zero. the synthesis
    !                 is performed on the entire sphere.  i.e. the arrays
    !                 vt(i, j), wt(i, j) are computed for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !            = 3  vt is odd and wt is even about the equator. the
    !                 synthesis is performed on the northern hemisphere
    !                 only.  i.e., if nlat is odd the arrays vt(i, j), wt(i, j)
    !                 are computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 4  vt is odd and wt is even about the equator and the
    !                 coefficients cr and ci are zero. the synthesis is
    !                 performed on the northern hemisphere only. i.e. if
    !                 nlat is odd the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the arrays vt(i, j), wt(i, j) are computed for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 5  vt is odd and wt is even about the equator and the
    !                 coefficients br and bi are zero. the synthesis is
    !                 performed on the northern hemisphere only. i.e. if
    !                 nlat is odd the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the arrays vt(i, j), wt(i, j) are computed for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 6  vt is even and wt is odd about the equator. the
    !                 synthesis is performed on the northern hemisphere
    !                 only.  i.e., if nlat is odd the arrays vt(i, j), wt(i, j)
    !                 are computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 7  vt is even and wt is odd about the equator and the
    !                 coefficients cr and ci are zero. the synthesis is
    !                 performed on the northern hemisphere only. i.e. if
    !                 nlat is odd the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the arrays vt(i, j), wt(i, j) are computed for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 8  vt is even and wt is odd about the equator and the
    !                 coefficients br and bi are zero. the synthesis is
    !                 performed on the northern hemisphere only. i.e. if
    !                 nlat is odd the arrays vt(i, j), wt(i, j) are computed
    !                 for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the arrays vt(i, j), wt(i, j) are computed for
    !                 i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of syntheses.  in the program that calls vtsec,
    !            the arrays vt, wt, br, bi, cr, and ci can be three dimensional
    !            in which case multiple syntheses will be performed.
    !            the third index is the synthesis index which assumes the
    !            values k=1, ..., nt.  for a single synthesis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that all the arrays are two
    !            dimensional.
    !
    !     idvw   the first dimension of the arrays vt, wt as it appears in
    !            the program that calls vtsec. if ityp <= 2 then idvw
    !            must be at least nlat.  if ityp > 2 and nlat is
    !            even then idvw must be at least nlat/2. if ityp > 2
    !            and nlat is odd then idvw must be at least (nlat + 1)/2.
    !
    !     jdvw   the second dimension of the arrays vt, wt as it appears in
    !            the program that calls vtsec. jdvw must be at least nlon.
    !
    !     br, bi  two or three dimensional arrays (see input parameter nt)
    !     cr, ci  that contain the vector spherical harmonic coefficients
    !            of (v, w) as computed by subroutine vhaec.
    !
    !     mdab   the first dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vtsec. mdab must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vtsec. ndab must be at
    !            least nlat.
    !
    !     wvts   an array which must be initialized by subroutine vtseci.
    !            once initialized, wvts can be used repeatedly by vtsec
    !            as long as nlon and nlat remain unchanged.  wvts must
    !            not be altered between calls of vtsec.
    !
    !     lwvts  the dimension of the array wvts as it appears in the
    !            program that calls vtsec. define
    !
    !               l1 = min(nlat, nlon/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lwvts must be at least
    !
    !            4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+nlon+15
    !
    !     output parameters
    !
    !     vt, wt  two or three dimensional arrays (see input parameter nt)
    !            in which the derivative of (v, w) with respect to
    !            colatitude theta is stored. vt(i, j), wt(i, j) contain the
    !            derivatives at colatitude theta(i) = (i-1)*pi/(nlat-1)
    !            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
    !            are defined above at the input parameter ityp. vt and wt
    !            are computed from the formulas for v and w given in
    !            subroutine vhsec but with vbar and wbar replaced with
    !            their derivatives with respect to colatitude. these
    !            derivatives are denoted by vtbar and wtbar.
    !
    !   in terms of real variables this expansion takes the form
    !
    !             for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     vt(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !               .5*br(1, n+1)*vtbar(0, n, theta(i))
    !
    !     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
    !     n=nlat-1 of the real part of
    !
    !       (br(m+1, n+1)*vtbar(m, n, theta(i))
    !                   -ci(m+1, n+1)*wtbar(m, n, theta(i)))*cos(m*phi(j))
    !      -(bi(m+1, n+1)*vtbar(m, n, theta(i))
    !                   +cr(m+1, n+1)*wtbar(m, n, theta(i)))*sin(m*phi(j))
    !
    !    and for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     wt(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !              -.5*cr(1, n+1)*vtbar(0, n, theta(i))
    !
    !     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
    !     n=nlat-1 of the real part of
    !
    !      -(cr(m+1, n+1)*vtbar(m, n, theta(i))
    !                   +bi(m+1, n+1)*wtbar(m, n, theta(i)))*cos(m*phi(j))
    !      +(ci(m+1, n+1)*vtbar(m, n, theta(i))
    !                   -br(m+1, n+1)*wtbar(m, n, theta(i)))*sin(m*phi(j))
    !
    !
    !      br(m+1, nlat), bi(m+1, nlat), cr(m+1, nlat), and ci(m+1, nlat) are
    !      assumed zero for m even.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of ityp
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idvw
    !            = 6  error in the specification of jdvw
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lwvts
    !
    module subroutine vtsec(nlat, nlon, ityp, nt, vt, wt, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvts, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: vt(idvw, jdvw, nt)
        real(wp),    intent(out) :: wt(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(in)  :: br(mdab, ndab, nt)
        real(wp),    intent(in)  :: bi(mdab, ndab, nt)
        real(wp),    intent(in)  :: cr(mdab, ndab, nt)
        real(wp),    intent(in)  :: ci(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvts(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: idv, imid, ist, labc, lzz1, mmax, lwork

        ! Check calling arguments
        call check_calling_arguments(nlat, nlon, ityp, nt, &
            idvw, jdvw, mdab, ndab, wvts, ierror, get_lwvts(nlat,nlon))

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

        mmax = min(nlat, (nlon + 1)/2)
        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2

        ! Set required workspace size
        select case (ityp)
            case (0:2)
                ist = imid
                idv = nlat
                lwork = nlat*(2*nt*nlon+max(6*imid, nlon))
            case default
                ist = 0
                idv = imid
                lwork = imid*(2*nt*nlon+max(6*nlat, nlon))
        end select

        block
            real(wp)    :: work(lwork)
            integer(ip) :: lnl, lwzvin, jw1, jw2
            integer(ip) :: iw1, iw2, iw3, iw4, iw5

            lnl = nt*idv*nlon
            iw1 = ist+1
            iw2 = lnl+1
            iw3 = iw2+ist
            iw4 = iw2+lnl
            iw5 = iw4+3*imid*nlat
            lwzvin = lzz1+labc
            jw1 = lwzvin+1
            jw2 = jw1+lwzvin

            call vtsec_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, jdvw, &
                vt, wt, mdab, ndab, br, bi, cr, ci, idv, work, work(iw1:), work(iw2:), &
                work(iw3:), work(iw4:), work(iw5:), wvts, wvts(jw1:), wvts(jw2:))
        end block

    end subroutine vtsec
    !
    !     subroutine vtseci(nlat, nlon, wvts, ierror)
    !
    !     subroutine vtseci initializes the array wvts which can then be
    !     used repeatedly by subroutine vtsec until nlat or nlon is changed.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     lwvts  the dimension of the array wvts as it appears in the
    !            program that calls vtsec. define
    !
    !               l1 = min(nlat, nlon/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lwvts must be at least
    !
    !            4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+nlon+15
    !
    !     output parameters
    !
    !     wvts   an array which is initialized for use by subroutine vtsec.
    !            once initialized, wvts can be used repeatedly by vtsec
    !            as long as nlat or nlon remain unchanged.  wvts must not
    !            be altered between calls of vtsec.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lwvts
    !
    module subroutine vtseci(nlat, nlon, wvts, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wvts(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)             :: imid, labc, lzz1
        integer(ip)             :: mmax, ldwork
        type(SpherepackUtility) :: util

        ! Check calling arguments
        call check_init_calling_arguments(&
            nlat, nlon, wvts, ierror, get_lwvts(nlat,nlon))

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

        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        mmax = min(nlat, (nlon + 1)/2)
        labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2

        ! Set required workspace length
        ldwork = 2*nlat + 2

        block
            real(wp)    :: dwork(ldwork)
            integer(ip) :: lwvbin, iw1, iw2

            ! Set workspace index pointers
            lwvbin = lzz1+labc
            iw1 = lwvbin+1
            iw2 = iw1+lwvbin

            call util%initialize_polar_components_regular_colat_deriv(nlat, nlon, wvts, dwork)

            call util%initialize_azimuthal_components_regular_colat_deriv(nlat, nlon, wvts(iw1:), dwork)

            call util%hfft%initialize(nlon, wvts(iw2:))
        end block

    end subroutine vtseci

    subroutine vtsec_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, jdvw, vt, wt, mdab, &
        ndab, br, bi, cr, ci, idv, vte, vto, wte, wto, vb, wb, wvbin, wwbin, wrfft)

        real(wp) :: bi
        real(wp) :: br
        real(wp) :: ci
        real(wp) :: cr
        integer(ip) :: i
        integer(ip) :: idv
        integer(ip) :: idvw
        integer(ip) :: imid
        integer(ip) :: imm1
        integer(ip) :: ityp
        integer(ip) :: iv
        integer(ip) :: iw
        integer(ip) :: j
        integer(ip) :: jdvw
        integer(ip) :: k
        integer(ip) :: m
        integer(ip) :: mdab
        integer(ip) :: mlat
        integer(ip) :: mlon
        integer(ip) :: mmax
        integer(ip) :: mp1
        integer(ip) :: mp2
        integer(ip) :: ndab
        integer(ip) :: ndo1
        integer(ip) :: ndo2
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nlp1
        integer(ip) :: np1
        integer(ip) :: nt
        real(wp) :: vb
        real(wp) :: vt
        real(wp) :: vte
        real(wp) :: vto
        real(wp) :: wb
        real(wp) :: wrfft
        real(wp) :: wt
        real(wp) :: wte
        real(wp) :: wto
        real(wp) :: wvbin
        real(wp) :: wwbin
        dimension vt(idvw, jdvw, nt), wt(idvw, jdvw, nt), br(mdab, ndab, nt), &
            bi(mdab, ndab, nt), cr(mdab, ndab, nt), ci(mdab, ndab, nt), &
            vte(idv, nlon, nt), vto(idv, nlon, nt), wte(idv, nlon, nt), &
            wto(idv, nlon, nt), wvbin(*), wwbin(*), wrfft(*), &
            vb(imid, nlat, 3), wb(imid, nlat, 3)

        type(SpherepackUtility) :: util

        nlp1 = nlat+1
        mlat = mod(nlat, 2)
        mlon = mod(nlon, 2)
        mmax = min(nlat, (nlon + 1)/2)

        select case(mlat)
            case(0)
                imm1 = imid
                ndo1 = nlat
                ndo2 = nlat-1
            case default
                imm1 = imid-1
                ndo1 = nlat-1
                ndo2 = nlat
        end select

        ! Preset even fields to zero
        vte = ZERO
        wte = ZERO

        vector_symmetry_cases: select case (ityp)
            case (0)
                ! case ityp=0   no symmetries
                call util%compute_polar_component(0, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            vto(i, 1, k)=vto(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                            wto(i, 1, k)=wto(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            vte(i, 1, k)=vte(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                            wte(i, 1, k)=wte(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(0, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(0, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, np1, iv)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, np1, iv)
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, np1, iv)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, np1, iw)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, np1, iw)
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, np1, iw)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(1)
                     ! case ityp=1   no symmetries,  cr and ci equal zero
                call util%compute_polar_component(0, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            vto(i, 1, k)=vto(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            vte(i, 1, k)=vte(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(0, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(0, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, np1, iv)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, np1, iw)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(2)
                        ! case ityp=2   no symmetries,  br and bi are equal to zero
                call util%compute_polar_component(0, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            wto(i, 1, k)=wto(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            wte(i, 1, k)=wte(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(0, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(0, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, np1, iv)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, np1, iw)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(3)
                        ! case ityp=3   v odd,  w even
                call util%compute_polar_component(0, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            vto(i, 1, k)=vto(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            wte(i, 1, k)=wte(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(0, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(0, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, np1, iv)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, np1, iw)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(4)
                       ! case ityp=4   v odd,  w even, and both cr and ci equal zero
                call util%compute_polar_component(1, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            vto(i, 1, k)=vto(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(1, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(1, nlat, nlon, m, wb, iw, wwbin)
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, np1, iw)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(5)
                        ! case ityp=5   v odd,  w even,     br and bi equal zero
                call util%compute_polar_component(2, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            wte(i, 1, k)=wte(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(2, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(2, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vto(i, 2*mp1-2, k) = vto(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vto(i, 2*mp1-1, k) = vto(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wte(i, 2*mp1-2, k) = wte(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wte(i, 2*mp1-1, k) = wte(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    wte(imid, 2*mp1-2, k) = wte(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, np1, iv)
                                    wte(imid, 2*mp1-1, k) = wte(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                end do
            case(6)
                       ! case ityp=6   v even  ,  w odd
                call util%compute_polar_component(0, nlat, nlon, 0, vb, iv, wvbin)
                        !
                        ! case m = 0
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            wto(i, 1, k)=wto(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            vte(i, 1, k)=vte(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(0, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(0, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, np1, iv)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, np1, iw)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
            case(7)
                       ! case ityp=7   v even, w odd   cr and ci equal zero
                call util%compute_polar_component(2, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=3, ndo1, 2
                        do i=1, imid
                            vte(i, 1, k)=vte(i, 1, k)+br(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(2, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(2, nlat, nlon, m, wb, iw, wwbin)
                    if (mp1 <= ndo1) then
                        do k=1, nt
                            do np1=mp1, ndo1, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, np1, iv)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, np1, iw)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, np1, iv)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, np1, iv)
                                end if
                            end do
                        end do
                    end if
                end do
            case(8)
                        ! case ityp=8   v even,  w odd   br and bi equal zero
                call util%compute_polar_component(1, nlat, nlon, 0, vb, iv, wvbin)
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, ndo2, 2
                        do i=1, imm1
                            wto(i, 1, k)=wto(i, 1, k)-cr(1, np1, k)*vb(i, np1, iv)
                        end do
                    end do
                end do
                !
                ! case m = 1 through nlat-1
                !
                if (mmax < 2) exit vector_symmetry_cases
                do mp1=2, mmax
                    m = mp1-1
                    mp2 = mp1+1
                    call util%compute_polar_component(1, nlat, nlon, m, vb, iv, wvbin)
                    call util%compute_azimuthal_component(1, nlat, nlon, m, wb, iw, wwbin)
                    if (mp2 <= ndo2) then
                        do k=1, nt
                            do np1=mp2, ndo2, 2
                                do i=1, imm1
                                    vte(i, 2*mp1-2, k) = vte(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, np1, iw)
                                    vte(i, 2*mp1-1, k) = vte(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, np1, iw)
                                    wto(i, 2*mp1-2, k) = wto(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, np1, iv)
                                    wto(i, 2*mp1-1, k) = wto(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, np1, iv)
                                end do
                                if (mlat /= 0) then
                                    vte(imid, 2*mp1-2, k) = vte(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, np1, iw)
                                    vte(imid, 2*mp1-1, k) = vte(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, np1, iw)
                                end if
                            end do
                        end do
                    end if
                end do
        end select vector_symmetry_cases

        do k=1, nt
            call util%hfft%backward(idv, nlon, vte(:, :, k), idv, wrfft)
            call util%hfft%backward(idv, nlon, wte(:, :, k), idv, wrfft)
        end do

        select case (ityp)
            case(0:1)
                do k=1, nt
                    do j=1, nlon
                        do i=1, imm1
                            vt(i, j, k) = HALF *(vte(i, j, k)+vto(i, j, k))
                            wt(i, j, k) = HALF *(wte(i, j, k)+wto(i, j, k))
                            vt(nlp1-i, j, k) = HALF *(vte(i, j, k)-vto(i, j, k))
                            wt(nlp1-i, j, k) = HALF *(wte(i, j, k)-wto(i, j, k))
                        end do
                    end do
                end do
            case default
                do k=1, nt
                    do j=1, nlon
                        do i=1, imm1
                            vt(i, j, k) = HALF *vte(i, j, k)
                            wt(i, j, k) = HALF *wte(i, j, k)
                        end do
                    end do
                end do
        end select

        if (mlat /= 0) then
            do k=1, nt
                do j=1, nlon
                    vt(imid, j, k) = HALF *vte(imid, j, k)
                    wt(imid, j, k) = HALF *wte(imid, j, k)
                end do
            end do
        end if

    end subroutine vtsec_lower_utility_routine

end submodule colatitudinal_derivative_regular_grid


module rpoisson

! Routines in this module solve the radial Poisson equation outward using
! the predictor-corrector method (with Adams extrapolation/interpolation).

use types, only: dp
use utils, only: stop_error
use constants, only: pi
use ode1d, only: adams_extrapolation_outward, adams_interp_outward
use ode1d, only: integrate, get_midpoints, rk4_integrate3

implicit none

private
public rpoisson_outward_pc

contains

function rpoisson_outward_pc(R, Rp, rho) result(V)
! Solves the equation V''(r) + 2/r*V'(r) = -4*pi*rho
!
! Uses predictor corrector Adams method.
!
! It rewrites it to the equivalent system of first order ODEs on a uniform
! grid:
!   u1 = V
!   u2 = V'
!   u1p = u2 * Rp
!   u2p = -(4*pi*rho + 2*u2/r) * Rp
! and integrates outward using Adams method. The initial conditions are:
!   V (R(1)) = u1(1) = 4*pi * \int r * rho(r) dr
!   V'(R(1)) = u2(1) = 0
real(dp), intent(in) :: R(:), Rp(:), rho(:)
real(dp) :: V(size(R))

real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: N, i, it
integer, parameter :: max_it = 2
real(dp) :: rho_mid(3)

N = size(R)
rho_mid = get_midpoints(R(:4), rho(:4))
call rpoisson_outward_rk4(rho(:4), rho_mid, R(:4), &
    4*pi*integrate(Rp, rho*R), &
    0.0_dp, &
    u1(:4), u2(:4))

u1p(:4) = u2(:4) * Rp(:4)
u2p(:4) = -(4*pi*rho(:4) + 2*u2(:4)/R(:4)) * Rp(:4)

do i = 4, N-1
    u1(i+1)  = u1(i)  + adams_extrapolation_outward(u1p, i)
    u2(i+1)  = u2(i)  + adams_extrapolation_outward(u2p, i)
    do it = 1, max_it
        u1p(i+1) = +Rp(i+1) * u2(i+1)
        u2p(i+1) = -Rp(i+1) * (4*pi*rho(i+1) + 2*u2(i+1)/R(i+1))
        u1(i+1)  = u1(i)  + adams_interp_outward(u1p, i)
        u2(i+1)  = u2(i)  + adams_interp_outward(u2p, i)
    end do
end do
V = u1
end function

subroutine rpoisson_outward_rk4(density, density_mid, R, V0, V0d, V, Vd)
! Solves V''(r) + 2/r*V'(r) = -4*pi*density (in this form) with initial
! conditions V(R(1)) = V0 and V'(R(1)) = V0d using 4th order Runge-Kutta method
! by rewriting it to the equivalent first order ODEs (see the documentation
! of rk4_integrate3() for more details). Returns V (value) and Vd (derivative).
real(dp), intent(in), dimension(:) :: density, density_mid ! density at the
    ! mesh points R and at midpoints
real(dp), intent(in), dimension(:) :: R ! radial grid
real(dp), intent(in) :: V0  ! value of V(r) at r=R(1)
real(dp), intent(in) :: V0d ! value of V'(r) at r=R(1)
real(dp), intent(out), dimension(:) :: V, Vd  ! V(r) and V'(r) on the grid R

real(dp) :: y(2)
real(dp), dimension(size(R)) :: C1, C2
real(dp), dimension(size(R)-1) :: C1mid, C2mid
real(dp), dimension(size(R)-1) :: Rmid
integer :: imax

y(1) = V0
y(2) = V0d

C1 = -4*pi*density
C2 = -2 / R
Rmid = (R(:size(R)-1) + R(2:)) / 2
C1mid = -4*pi*density_mid
C2mid = -2 / Rmid
call rk4_integrate3(R, y, C1, C2, C1mid, C2mid, 1e10_dp, V, Vd, imax)
if (imax /= size(R)) call stop_error("Poisson solver diverged.")
end subroutine

end module


SUBROUTINE Easter(year, day, month)
! U.S. Naval Observatory Astronomical Applications Department

!            The Date of Easter (Sunday)

! The algorithm is due to J.-M. Oudin (1940) and is reprinted in the Explanatory
! Supplement to the Astronomical Almanac, ed. P. K. Seidelmann (1992).
! See Chapter 12, "Calendars", by L. E. Doggett.

! The following are dates of Easter from 1980 to 2024:

! 1980  April  6        1995  April 16        2010  April  4
! 1981  April 19        1996  April  7        2011  April 24
! 1982  April 11        1997  March 30        2012  April  8
! 1983  April  3        1998  April 12        2013  March 31
! 1984  April 22        1999  April  4        2014  April 20
! 1985  April  7        2000  April 23        2015  April  5
! 1986  March 30        2001  April 15        2016  March 27
! 1987  April 19        2002  March 31        2017  April 16
! 1988  April  3        2003  April 20        2018  April  1
! 1989  March 26        2004  April 11        2019  April 21
! 1990  April 15        2005  March 27        2020  April 12
! 1991  March 31        2006  April 16        2021  April  4
! 1992  April 19        2007  April  8        2022  April 17
! 1993  April 11        2008  March 23        2023  April  9
! 1994  April  3        2009  April 12        2024  March 31

! N.B. The date of Easter for the Eastern Orthodox Church may be different.

! This code assembled by Alan Miller
! Reference web site:
! http://aa.usno.navy.mil/faq/docs/easter.html
! Latest revision 8 April 2002

IMPLICIT NONE
INTEGER, INTENT(IN)   :: year
INTEGER, INTENT(OUT)  :: day, month

! Local variables
INTEGER  :: c, i, j, k, l, n

c = year / 100
n = year - 19 * ( year / 19 )
k = ( c - 17 ) / 25
i = c - c / 4 - ( c - k ) / 3 + 19 * n + 15
i = i - 30 * ( i / 30 )
i = i - (i / 28) * (1 - (i / 28) * (29 / (i + 1 )) * ( (21 - n) / 11) )
j = year + year / 4 + i + 2 - c + c / 4
j = j - 7 * ( j / 7 )
l = i - j
month = 3 + ( l + 40 ) / 44
day = l + 28 - 31 * ( month / 4 )

RETURN
END SUBROUTINE Easter

PROGRAM test_Easter
! Generate the table contained in the subroutine.

IMPLICIT NONE

INTERFACE
  SUBROUTINE Easter(year, day, month)
    IMPLICIT NONE
    INTEGER, INTENT(IN)   :: year
    INTEGER, INTENT(OUT)  :: day, month
  END SUBROUTINE Easter
END INTERFACE

INTEGER            :: day(1980:2024), month(1980:2024), year, y2, y3
CHARACTER (LEN=5)  :: mon(3:4) = (/ 'March', 'April' /)

DO year = 1980, 2024
  CALL Easter(year, day(year), month(year))
END DO

DO year = 1980, 1994
  y2 = year + 15
  y3 = y2 + 15
  WRITE(*, '(3("  ", i4, "  ", a5, i3, "      "))')  &
           year, mon(month(year)), day(year),  &
           y2, mon(month(y2)), day(y2),  &
           y3, mon(month(y3)), day(y3)
END DO
STOP
END PROGRAM test_Easter


program pernicious
  implicit none

  integer :: i, n

  i = 1
  n = 0
  do
    if(isprime(popcnt(i))) then
      write(*, "(i0, 1x)", advance = "no") i
      n = n + 1
      if(n == 25) exit
    end if
    i = i + 1
  end do

  write(*,*)
  do i = 888888877, 888888888
    if(isprime(popcnt(i))) write(*, "(i0, 1x)", advance = "no") i
  end do

contains

function popcnt(x)
  integer :: popcnt
  integer, intent(in) :: x
  integer :: i

  popcnt = 0
  do i = 0, 31
    if(btest(x, i)) popcnt = popcnt + 1
  end do

end function

function isprime(number)
  logical :: isprime
  integer, intent(in) :: number
  integer :: i

  if(number == 2) then
    isprime = .true.
  else if(number < 2 .or. mod(number,2) == 0) then
    isprime = .false.
  else
    isprime = .true.
    do i = 3, int(sqrt(real(number))), 2
      if(mod(number,i) == 0) then
        isprime = .false.
        exit
      end if
    end do
  end if
end function
end program


function relief_surf(fi,tet)

common/topo/hsurf,nfi,fmin,fmax,ntet,tmin,tmax,htopo(1500,1500)

hhh=0.

!write(*,*)' nfi=',nfi,' fi=',fi,' fmin=',fmin,' fmax=',fmax

if (nfi.eq.0) then
	h_lim=0
	return
end if

if ((fi-fmin)*(fi-fmax).gt.0) then
	h_lim=0
	return
end if

if ((tet-tmin)*(tet-tmax).gt.0) then
	h_lim=0
	return
end if

df=(fmax-fmin)/nfi
dt=(tmax-tmin)/ntet

do ifi=1,nfi
	f1=fmin+df*(ifi-1)
	f2=fmin+df*ifi
	if ((fi-f1)*(fi-f2).gt.0.) cycle
	exit
end do

do itet=1,ntet
	t1=tmin+dt*(itet-1)
	t2=tmin+dt*itet
	if ((tet-t1)*(tet-t2).gt.0.) cycle
	exit
end do

h11=htopo(ifi,itet)
h12=htopo(ifi,itet+1)
h21=htopo(ifi+1,itet)
h22=htopo(ifi+1,itet+1)

h1=h11+(h11-h12)*(tet-t1)/(t1-t2)
h2=h21+(h21-h22)*(tet-t1)/(t1-t2)

hhh=h1+(h1-h2)*(fi-f1)/(f1-f2)

relief_surf=-hhh

return
end


	SUBROUTINE TUPPOW(ALPHA,BETA,N,M,P0,R,PSIMAX,INCRE,PSI)
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Power calculations for matched 2XM tables
C  Arguments:
C   i	ALPHA	(REAL)
C	Type I error
C   i	BETA	(REAL)
C	Type II error
C   i	N	(Integer)
C	Number of case patients
C   i	M	(Integer)
C	Number of matched controls per case patient
C   i	P0	(REAL)
C	Probability of exposure in control group
C   i	R	(REAL)
C	Correlation coefficient
C   i	PSIMAX	(REAL)
C	An odds ratio - See output
C   i	INCRE	(REAL)
C	Increment size
C   o	PSI	(REAL)
C     = the value of the odds ratio that can be detected with power 1-BETA
C	if this PSI is less than or equal to PSIMAX.
C     = -1 if the power associated with the odds ratio (PSIMAX) is less
C	than 1-BETA or if N is too small to permit valid normal
C	approximations.
C     = -2 if no PSI exists with the required power givenx P0 and R.
C     = -3 if N is too small to permit valid normal approximations.
C  Notes:
C   .	This routine was written by Dale Plummer.
C   .	Designed by Dr. William Dupont.  This program was written to
C	produce the isographs in Dupont (Biometrics, 1988; 44:1157-1168)
C   .	The minimum value of N that will permit valid normal approxiamations
C	depends on P0, R, and M.
C   .	We will find PSI by either the secant method or the method of
C	false position.  The latter method will be used whenever the
C	secant method threatens to diverge.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL ALPHA,BETA,P0,R,PSIMAX,PSI,INCRE
	INTEGER N,M
C
C  Functions
C
	REAL ZCRVALUE
C
C  Locals
C
	REAL ZALPHA,POWER,TPOWER,PU,PSIU,PL,PSIL,POLD,PSIOLD,P
	REAL SLOPE,PSINEW,PNEW,PSITOP
	INTEGER ERR
C
C-Code------------------------------------------------------------------
C
	POWER=1.-BETA
	ZALPHA=ZCRVALUE(ALPHA/2.)
	CALL POWFCN(ZALPHA,N,R,P0,M,PSIMAX,TPOWER,ERR)
	IF (ERR.GE.1) THEN
	    PSI=-1-ERR
	    RETURN
	END IF
	IF (TPOWER.LT.POWER) THEN
	    PSI=-1.
	    RETURN
	END IF
	PU=TPOWER
	PSIU=PSIMAX
C
C    Find a valid lower value for PSIL.
C
	PSITOP=PSIMAX
	PSIL=1.0
10	CONTINUE
	    IF (PSITOP-PSIL.LE.0.1) GO TO 20
	    PSI=((PSITOP-PSIL)/2.)+PSIL
	    CALL POWFCN(ZALPHA,N,R,P0,M,PSI,P,ERR)
	    IF (ERR.EQ.0) THEN
			IF (P.LE.POWER) THEN
				PL=P
				PSIL=PSI
				GOTO 2
			END IF
			PSITOP=PSI
	    ELSE
			PSIL=PSI
	    END IF
	GO TO 10
20	CONTINUE
C    No valid lower bound exists.
	PSI=-2
	RETURN
C    Come to here when found valid lower bound on PSI.
2	CONTINUE
	IF (PU-POWER.GE.POWER-PL) THEN
	    POLD=PU
	    PSIOLD=PSIU
	    P=PL
	    PSI=PSIL
	ELSE
	    POLD=PL
	    PSIOLD=PSIL
	    P=PU
	    PSI=PSIU
	END IF
C
C    Try an iteration of the secant method.
C
30	CONTINUE
	    IF (ABS(P-POWER).LT.INCRE) GO TO 40
	    SLOPE=(POLD-P)/(PSIOLD-PSI)
	    PSINEW=(POWER+SLOPE*PSI-P)/SLOPE
	    IF (PSIL.LT.PSINEW.AND.PSINEW.LT.PSIU) THEN
C
C    The secant method looks OK.
C
			CALL POWFCN(ZALPHA,N,R,P0,M,PSINEW,PNEW,ERR)
			IF (ABS(PNEW-POWER).LT.ABS(P-POWER))THEN
C
C    The secant method *is* OK.
C
				IF (POLD.GE.POWER) THEN
C
C    Reduce PU.
C
					PU=POLD
					PSIU=PSIOLD
				ELSE
C
C    Increase PL.
C
					PL=POLD
					PSIL=PSIOLD
				END IF
				POLD=P
				PSIOLD=PSI
				P=PNEW
				PSI=PSINEW
C
C    This iteration is finished.
C
				GOTO 1
			ELSE
C
C    Prepare for iteration of false position method.
C
				IF (PNEW.GE.POWER.AND.PNEW.LT.PU) THEN
C
C    Reduce PU.
C
					PU=PNEW
					PSIU=PSINEW
				ELSE IF (PNEW.LT.POWER.AND.PL.LT.PNEW) THEN
C
C    Increase PL.
C
					PL=PNEW
					PSIL=PSINEW
				END IF
			END IF
	    END IF
C
C    Now do an iteration of false position method.
C
	    SLOPE=(PU-PL)/(PSIU-PSIL)
	    PSI=(POWER+SLOPE*PSIL-PL)/SLOPE
	    CALL POWFCN(ZALPHA,N,R,P0,M,PSI,P,ERR)
	    IF (P.GE.POWER) THEN
C
C    Reduce PU.
C
			PU=P
			PSIU=PSI
	    ELSE
C
C    Increase PL.
C
			PL=P
			PSIL=PSI
	    END IF
C
C    Get ready to try secant method again.
C
	    IF (POWER-PL.LE.PU-POWER) THEN
			P=PL
			PSI=PSIL
			POLD=PU
			PSIOLD=PSIU
	    ELSE
			P=PU
			PSI=PSIU
			POLD=PL
			PSIOLD=PSIL
	    END IF
C
C    Continue with the secant method.
C
1	    CONTINUE
	GO TO 30
40	CONTINUE
C
C    Finished.
C
	RETURN
	END


module finite_differences
!+Description
!  This module contains routines to approximate mixed first derivatives to a discretely sampled function
!  using repeated one-dimensional parabolic interpolation. The function need not be sampled uniformly, but
!  it is assumed that the grid is Cartesian with coordinate grids that are independent of all other coordinates
!  (e.g. this does not work for AMR/nested grids)
!
!  The purpose of these routines is to approximate derivatives for use with the tricubic interpolation routines
!  that are used in our particle stepper. This hard-coded 2nd order method is much faster than the N-th order
!  Lagrange method. This is very similar to the finite_differences_qp module that had been previously used,
!  but a somewhat different formulation of the coefficients is used and it is a little more flexible.
!
!+Routines
!  deriv1    Approximate the first derivative of a 1-d function
!  deriv2    Approximate the mixed 2nd derivative of a 2-d function
!  deriv3    Approximate the mixed 3rd derivative of a 3-d function
!
!+Author
!  Jesse Woodroffe
!  jwoodroffe@lanl.gov

use global

contains

  function deriv1(x,f,idx) result(der)
  !+Description
  !  Approximates the derivatives of a discretely sampled function by fitting a parabola
  !  and then differentiating the parabola:
  !
  !   f =  A(x-x0)^2 + B(x-x0) + C
  !  fp = 2A(x-x0) + B
  !
  !  The optional parameter idx allows us to specify if the derivative at the left (idx < 0) or right (idx>0)
  !  cell is desired instead of the center value. Derivatives at the center are slightly more accurate, but this
  !  option allows us to get derivatives at the edge of the grid.
  !
  !+Inputs
  !  x(3) double precision array of grid points
  !  f(3) double precision array of function values at the grid points
  !  idx  integer that specifies the grid point at which the derivative is to be evaluated
  !
  !+Outputs
  !  der  double precision scalar with derivative at desired grid point
  !
  ! Author:
  !  Jesse Woodroffe
  !  jwoodroffe@lanl.gov

  implicit none

  real(dp), dimension(3) :: x
  real(dp), dimension(3) :: f
  real(dp) :: A, B, p, q, dxp, dxm, dxtot, dfp, dfm, denom
  real(dp) :: der
  integer, intent(in) :: idx

  dxp = x(3)-x(2)
  dxm = x(2)-x(1)
  dxtot = dxp+dxm
  denom = 1.d0/(dxtot*dxp*dxm)

  dfp = f(3)-f(2)
  dfm = f(1)-f(2)

  p = dfm*dxp
  q = dfp*dxm

  B = denom*(dxm*q-dxp*p)

  der = 0.d0
  if(idx==0) then ! Evaluate at center
    der = B
  else if(idx==1) then ! Evaluate at right
    A = denom*(p+q)
    der = B+2*A*dxp
  else if(idx==-1) then ! Evaluate at left
    A = denom*(p+q)
    der = B-2*A*dxm
  endif

  return

  end function deriv1

!

  function deriv2(x,y,f,idx,idy) result(der)
  !+Description
  !  Calculate 2-d derivative using repeated application of 1d derivative.
  !
  !+Inputs
  !  x(3)   double precision array of grid points for dimension 1
  !  y(3)   double precision array of grid points for dimension 2
  !  f(3,3) double precision array of function values at the grid points
  !  idx    integer that specifies the grid point at which the derivative is to be evaluated in x
  !  idy    integer that specifies the grid point at which the derivative is to be evaluated in y
  !
  !+Outputs
  !  der  double precision scalar with derivative at desired grid point specified by idx, idy
  !
  !+Author
  !  Jesse Woodroffe
  !  jwoodroffe@lanl.gov
  !
  implicit none

  real(dp), dimension(3), intent(in) :: x, y
  real(dp), dimension(3,3), intent(in) :: f
  real(dp), dimension(3) :: temp
  real(dp) :: der
  integer, intent(in) :: idx, idy
  integer :: i

  do i=1,3
    temp(i) = deriv1(x,f(:,i),idx=idx)
  enddo

  der = deriv1(y,temp,idx=idy)

  return

  end function deriv2

!

  function deriv3(x,y,z,f,idx,idy,idz) result(der)
  !+Description
  !  Calculate 3-d derivative using repeated application of 1d derivative.
  !
  !+Inputs
  !  x(3)     double precision array of grid points for dimension 1
  !  y(3)     double precision array of grid points for dimension 2
  !  z(3)     double precision array of grid points for dimension 3
  !  f(3,3,3) double precision array of function values at the grid points
  !  idx      integer that specifies the grid point at which the derivative is to be evaluated in x
  !  idy      integer that specifies the grid point at which the derivative is to be evaluated in y
  !  idz      integer that specifies the grid point at which the derivative is to be evaluated in z
  !
  !+Outputs
  !  der  double precision scalar with derivative at desired grid point specified by idx, idy, idz
  !
  !+Author
  !  Jesse Woodroffe
  !  jwoodroffe@lanl.gov
  !
  implicit none

  real(dp), intent(in), dimension(3) :: x, y, z
  real(dp), intent(in), dimension(3,3,3) :: f
  real(dp), dimension(3) :: temp
  real(dp) :: der
  integer, intent(in) :: idx, idy, idz

  integer :: i

  do i=1,3
    temp(i) = deriv2(y,z,f(i,:,:),idx=idy,idy=idz)
  enddo

  der = deriv1(x,temp,idx=idx)

  return

  end function deriv3

end module finite_differences