!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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(vector_synthesis_routines) vector_synthesis_gaussian_saved

contains

    ! Purpose:
    !
    !     subroutine vhsgs(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
    !                      mdab, ndab, wvhsgs, ierror)
    !
    !     subroutine vhsgs performs the vector spherical harmonic synthesis
    !     of the arrays br, bi, cr, and ci and stores the result in the
    !     arrays v and w.  the synthesis is performed on an equally spaced
    !     longitude grid and a gaussian colatitude grid (measured from
    !     the north pole). v(i, j) and w(i, j) are the colatitudinal and
    !     east longitudinal components respectively, located at the i(th)
    !     colatitude gaussian point (see nlat below) and longitude
    !     phi(j) = (j-1)*2*pi/nlon.  the spectral respresentation of (v, w)
    !     is given below at output parameters v, w.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine
    !            compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(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. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !            = 1  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon. the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 2  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 arrays v(i, j), w(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon. the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !            = 3  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 4  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 5  v is symmetric and w is antisymmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !            = 6  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !            = 7  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the curl of (v, w) is zero. that is,
    !                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
    !                 the coefficients cr and ci are zero.
    !
    !            = 8  v is antisymmetric and w is symmetric about the
    !                 equator. the synthesis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the synthesis
    !                 is performed on the arrays v(i, j), w(i, j) for
    !                 i=1, ..., (nlat + 1)/2 and j=1, ..., nlon. if nlat is
    !                 even the synthesis is performed on the the arrays
    !                 v(i, j), w(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !                 the divergence of (v, w) is zero. i.e.,
    !                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
    !                 the coefficients br and bi are zero.
    !
    !
    !     nt     the number of syntheses.  in the program that calls vhsgs,
    !            the arrays v, w, 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 v, w as it appears in
    !            the program that calls vhags. 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 v, w as it appears in
    !            the program that calls vhsgs. 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
    !            in the spectral representation of v(i, j) and w(i, j) given
    !            below at the discription of output parameters v and w.
    !
    !     mdab   the first dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vhsgs. 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 vhsgs. ndab must be at
    !            least nlat.
    !
    !     wvhsgs an array which must be initialized by subroutine vhsgsi.
    !            once initialized, wvhsgs can be used repeatedly by vhsgs
    !            as long as nlon and nlat remain unchanged.  wvhsgs must
    !            not be altered between calls of vhsgs.
    !
    !     lvhsgs the dimension of the array wvhsgs as it appears in the
    !            program that calls vhsgs. 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 lvhsgs must be at least
    !
    !                 l1*l2*(2*nlat-l1+1)+nlon+15+2*nlat
    !
    !     output parameters
    !
    !     v, w    two or three dimensional arrays (see input parameter nt)
    !            in which the synthesis is stored. v is the colatitudinal
    !            component and w is the east longitudinal component.
    !            v(i, j), w(i, j) contain the components at the guassian colatitude
    !            point theta(i) and longitude phi(j) = (j-1)*2*pi/nlon.
    !            the index ranges are defined above at the input parameter
    !            ityp. v and w are computed from the formulas given below.
    !
    !
    !     define
    !
    !     1.  theta is colatitude and phi is east longitude
    !
    !     2.  the normalized associated legendre funnctions
    !
    !         pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)
    !                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
    !                        factorial(n)) times the (n+m)th derivative
    !                        of (x**2-1)**n with respect to x=cos(theta)
    !
    !     3.  vbar(m, n, theta) = the derivative of pbar(m, n, theta) with
    !                           respect to theta divided by the square
    !                           root of n(n+1).
    !
    !         vbar(m, n, theta) is more easily computed in the form
    !
    !         vbar(m, n, theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1, n, theta)
    !         -sqrt((n-m)*(n+m+1))*pbar(m+1, n, theta))/(2*sqrt(n*(n+1)))
    !
    !     4.  wbar(m, n, theta) = m/(sin(theta))*pbar(m, n, theta) divided
    !                           by the square root of n(n+1).
    !
    !         wbar(m, n, theta) is more easily computed in the form
    !
    !         wbar(m, n, theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
    !         *pbar(m-1, n-1, theta)+sqrt((n-m)*(n-m-1))*pbar(m+1, n-1, theta))
    !         /(2*sqrt(n*(n+1)))
    !
    !
    !    the colatitudnal dependence of the normalized surface vector
    !                spherical harmonics are defined by
    !
    !     5.    bbar(m, n, theta) = (vbar(m, n, theta), i*wbar(m, n, theta))
    !
    !     6.    cbar(m, n, theta) = (i*wbar(m, n, theta), -vbar(m, n, theta))
    !
    !
    !    the coordinate to index mappings
    !
    !     7.   theta(i) = i(th) gaussian grid point and phi(j) = (j-1)*2*pi/nlon
    !
    !
    !     the maximum (plus one) longitudinal wave number
    !
    !     8.     mmax = min(nlat, nlon/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !    if we further define the output vector as
    !
    !     9.    h(i, j) = (v(i, j), w(i, j))
    !
    !    and the complex coefficients
    !
    !     10.   b(m, n) = cmplx(br(m+1, n+1), bi(m+1, n+1))
    !
    !     11.   c(m, n) = cmplx(cr(m+1, n+1), ci(m+1, n+1))
    !
    !
    !    then for i=1, ..., nlat and  j=1, ..., nlon
    !
    !        the expansion for real h(i, j) takes the form
    !
    !     h(i, j) = the sum from n=1 to n=nlat-1 of the real part of
    !
    !         .5*(b(0, n)*bbar(0, n, theta(i))+c(0, n)*cbar(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
    !
    !              b(m, n)*bbar(m, n, theta(i))*exp(i*m*phi(j))
    !             +c(m, n)*cbar(m, n, theta(i))*exp(i*m*phi(j))
    !
    !   *************************************************************
    !
    !   in terms of real variables this expansion takes the form
    !
    !             for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     v(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !               .5*br(1, n+1)*vbar(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)*vbar(m, n, theta(i))-ci(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *cos(m*phi(j))
    !      -(bi(m+1, n+1)*vbar(m, n, theta(i))+cr(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *sin(m*phi(j))
    !
    !    and for i=1, ..., nlat and  j=1, ..., nlon
    !
    !     w(i, j) = the sum from n=1 to n=nlat-1 of
    !
    !              -.5*cr(1, n+1)*vbar(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)*vbar(m, n, theta(i))+bi(m+1, n+1)*wbar(m, n, theta(i)))
    !                                          *cos(m*phi(j))
    !      +(ci(m+1, n+1)*vbar(m, n, theta(i))-br(m+1, n+1)*wbar(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 lvhsgs
    !
    module subroutine vhsgs(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvhsgs, 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)    :: v(idvw, jdvw, nt)
        real(wp),    intent(out)    :: w(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)     :: wvhsgs(:)
        integer(ip), intent(out)    :: ierror

        ! Local variables
        integer(ip) :: idv, idz, imid, ist, lnl, lzimn, mmax
        integer(ip) :: lwork, workspace_indices(7)

        associate (lvhsgs => size(wvhsgs))

            imid = (nlat + 1)/2
            mmax = min(nlat, (nlon + 1)/2)
            idz = (mmax*(2*nlat-mmax+1))/2
            lzimn = idz*imid

            ! Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 1) then
                ierror = 2
            else if (ityp < 0 .or. ityp > 8) then
                ierror = 3
            else if (nt < 0) then
                ierror = 4
            else if ( &
                (ityp <= 2 .and. idvw < nlat) &
                .or. &
                (ityp > 2 .and. idvw < imid)) then
                ierror = 5
            else if (jdvw < nlon) then
                ierror = 6
            else if (mdab < mmax) then
                ierror = 7
            else if (ndab < nlat) then
                ierror = 8
            else if (lvhsgs < 2*lzimn+nlon+15) then
                ierror = 9
            else
                ierror = 0
            end if

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

            ! Set required workspace size
            select case (ityp)
                case(0:2)
                    ist = imid
                    idv = nlat
                case default
                    ist = 0
                    idv = imid
            end select

            lnl = nt*idv*nlon
            lwork = (2 * lnl) + (idv * nlon)

            block
                real(wp) :: work(lwork)

                !  Compute workspace indices
                workspace_indices = get_vhsgs_workspace_indices(nlat, imid, ist, lnl)

                associate (&
                    jw1 => workspace_indices(1), &
                    jw2 => workspace_indices(2), &
                    jw3 => workspace_indices(3), &
                    iw1 => workspace_indices(4), &
                    iw2 => workspace_indices(5), &
                    iw3 => workspace_indices(6), &
                    iw4 => workspace_indices(7) &
                    )
                    call vhsgs_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, &
                        jdvw, v, w, mdab, ndab, br, bi, cr, ci, idv, work, work(iw1:), &
                        work(iw2:), work(iw3:), work(iw4:), idz, wvhsgs(jw1:), &
                        wvhsgs(jw2:), wvhsgs(jw3:))
                end associate
            end block
        end associate

    end subroutine vhsgs

    ! Purpose:
    !
    !     Computes the gaussian points theta, gauss
    !     weights wts, and the components vb and wb of the vector
    !     harmonics.
    !
    !     set imid = (nlat + 1)/2 and lmn=(nlat*(nlat + 1))/2 then
    !     wvhsgs must have 2*(imid*lmn+nlat)+nlon+15 locations
    !
    !     real array dwork must have
    !     3*nlat*(nlat + 1)+5*nlat+1 = nlat*(3*nlat+8)+1
    !     locations which is determined by the size of dthet,
    !     dwts, dwork, and dpbar in vhsgs_lower_utility_routine
    !
    !     subroutine vhsgsi(nlat, nlon, wvhsgs, ierror)
    !
    !     subroutine vhsgsi initializes the array wvhsgs which can then be
    !     used repeatedly by subroutine vhsgs until nlat or nlon is changed.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(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.
    !
    !     lvhsgs the dimension of the array wvhsgs as it appears in the
    !            program that calls vhsgs. 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 lvhsgs must be at least
    !
    !                 l1*l2*(2*nlat-l1+1)+nlon+15+2*nlat
    !
    !     output parameters
    !
    !     wvhsgs an array which is initialized for use by subroutine vhsgs.
    !            once initialized, wvhsgs can be used repeatedly by vhsgs
    !            as long as nlat and nlon remain unchanged.  wvhsgs must not
    !            be altered between calls of vhsgs.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lvhsgs
    !
    module subroutine vhsgsi(nlat, nlon, wvhsgs, ierror)

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

        ! Local variables
        integer(ip) :: imid, lmn, ldwork
        type(SpherepackUtility) :: util

        associate (lvhsgs => size(wvhsgs))

            imid = (nlat + 1)/2
            lmn = (nlat*(nlat + 1))/2

            !  Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 1) then
                ierror = 2
            else if (lvhsgs < 2*(imid*lmn) + nlon + 15) then
                ierror = 3
            else
                ierror = 0
            end if

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

            ! Set required workspace size
            ldwork = (nlat*3*(nlat+3)+2)/2

            block
                integer(ip) :: jw1, jw2, jw3
                integer(ip) :: iw1, iw2, iw3, iw4
                real(wp)    :: dwork(ldwork)

                ! Set saved workspace pointer indices
                jw1 = 1
                jw2 = jw1+imid*lmn
                jw3 = jw2+imid*lmn

                ! Set unsaved workspace pointer indices
                iw1 = 1
                iw2 = iw1+nlat
                iw3 = iw2+nlat
                iw4 = iw3+3*imid*nlat

                call vhgsi_lower_utility_routine(nlat, imid, wvhsgs(jw1:), &
                    wvhsgs(jw2:), dwork(iw1:), dwork(iw2:), dwork(iw3:), dwork(iw4:))

                call util%hfft%initialize(nlon, wvhsgs(jw3:))
            end block
        end associate

    end subroutine vhsgsi

    pure function get_vhsgs_workspace_indices(nlat, imid, ist, lnl) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: imid
        integer(ip), intent(in)  :: ist
        integer(ip), intent(in)  :: lnl
        integer(ip)              :: return_value(7)

        ! Local variables
        integer(ip) :: lmn

        associate (i => return_value)

            !  set wvhsgs pointers
            lmn = nlat*(nlat + 1)/2
            i(1) = 1
            i(2) = i(1)+imid*lmn
            i(3) = i(2)+imid*lmn

            !  set work pointers
            i(4) = ist+1
            i(5) = lnl+1
            i(6) = i(5)+ist
            i(7) = i(5)+lnl
        end associate

    end function get_vhsgs_workspace_indices

    subroutine vhsgs_lower_utility_routine(nlat, nlon, ityp, nt, imid, idvw, jdvw, v, w, mdab, &
        ndab, br, bi, cr, ci, idv, ve, vo, we, wo, work, idz, vb, wb, wrfft)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(in)  :: nt
        integer(ip), intent(in)  :: imid
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        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)  :: idv
        real(wp),    intent(out) :: ve(idv, nlon, nt)
        real(wp),    intent(out) :: vo(idv, nlon, nt)
        real(wp),    intent(out) :: we(idv, nlon, nt)
        real(wp),    intent(out) :: wo(idv, nlon, nt)
        real(wp),    intent(out) :: work(*)
        integer(ip), intent(in)  :: idz
        real(wp),    intent(in)  :: vb(imid, *)
        real(wp),    intent(in)  :: wb(imid, *)
        real(wp),    intent(in)  :: wrfft(*)

        ! Local variables
        integer(ip)    :: i, imm1, k, m, mb, mmax
        integer(ip)    :: mn, mp1, mp2, odd_stride, even_stride, np1
        type(VectorSynthesisUtility) :: util

        call util%synthesis_setup(even_stride, imid, imm1, mmax, nlat, &
            odd_stride, ve, vo, we, wo)

        vector_symmetry_cases: select case (ityp)
            case (0)
                                      ! case ityp=0   no symmetries
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                ! case m = 1 through nlat-1
                if (2 <= mmax) then
                    do mp1=2, mmax
                        m = mp1-1
                        mb = m * (nlat-1) - (m * (m - 1))/2
                        mp2 = mp1+1
                        if (mp1 <= odd_stride) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do

                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            -ci(mp1, np1, k)*wb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +cr(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -bi(mp1, np1, k)*wb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            +br(mp1, np1, k)*wb(imid, mn)
                                    end if
                                end do
                            end do
                        end if

                        if (mp2 <= even_stride) then
                            do k=1, nt
                                do np1=mp2, even_stride, 2
                                    mn = mb+np1
                                    do i=1, imm1
                                        ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                        vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                        ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                        vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                        we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                        wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                    end do
                                    if (mod(nlat, 2) /= 0) then
                                        ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                            +br(mp1, np1, k)*vb(imid, mn)
                                        ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                            +bi(mp1, np1, k)*vb(imid, mn)
                                        we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                            -cr(mp1, np1, k)*vb(imid, mn)
                                        we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                            -ci(mp1, np1, k)*vb(imid, mn)
                                    end if
                                end do
                            end do
                        end if
                    end do
                end if
            case (1)
                !
                ! case ityp=1   no symmetries,  cr and ci equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        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
                    !     mb = m*(nlat-1)-(m*(m-1))/2
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1
                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if

                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (2)
                !
                ! case ityp=2   no symmetries,  br and bi are equal to zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1

                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if

                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (3)
                !
                ! case ityp=3   v even,  w odd
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1
                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if

                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (4)
                !
                ! case ityp=4   v even,  w odd, and both cr and ci equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            ve(i, 1, k)=ve(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1

                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        +br(mp1, np1, k)*vb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +bi(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (5)
                 !
                 ! case ityp=5   v even,  w odd,     br and bi equal zero
                 !
                 ! case m = 0
                 !
                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            wo(i, 1, k)=wo(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1

                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    ve(i, 2*mp1-2, k) = ve(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    ve(i, 2*mp1-1, k) = ve(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    wo(i, 2*mp1-2, k) = wo(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    wo(i, 2*mp1-1, k) = wo(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    ve(imid, 2*mp1-2, k) = ve(imid, 2*mp1-2, k) &
                                        -ci(mp1, np1, k)*wb(imid, mn)
                                    ve(imid, 2*mp1-1, k) = ve(imid, 2*mp1-1, k) &
                                        +cr(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (6)
                !
                ! case ityp=6   v odd  ,  w even
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        end do
                    end do
                end do

                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1
                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if

                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (7)
                !
                ! case ityp=7   v odd, w even   cr and ci equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=3, odd_stride, 2
                        do i=1, imm1
                            vo(i, 1, k)=vo(i, 1, k)+br(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1
                    if (mp1 <= odd_stride) then
                        do k=1, nt
                            do np1=mp1, odd_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)+br(mp1, np1, k)*vb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+bi(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-bi(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)+br(mp1, np1, k)*wb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -bi(mp1, np1, k)*wb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        +br(mp1, np1, k)*wb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
            case (8)
                !
                ! case ityp=8   v odd,  w even   br and bi equal zero
                !
                ! case m = 0
                !
                do k=1, nt
                    do np1=2, even_stride, 2
                        do i=1, imid
                            we(i, 1, k)=we(i, 1, k)-cr(1, np1, k)*vb(i, np1)
                        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
                    mb = m*nlat-(m*(m+1))/2
                    mp2 = mp1+1
                    if (mp2 <= even_stride) then
                        do k=1, nt
                            do np1=mp2, even_stride, 2
                                mn = mb+np1
                                do i=1, imm1
                                    vo(i, 2*mp1-2, k) = vo(i, 2*mp1-2, k)-ci(mp1, np1, k)*wb(i, mn)
                                    vo(i, 2*mp1-1, k) = vo(i, 2*mp1-1, k)+cr(mp1, np1, k)*wb(i, mn)
                                    we(i, 2*mp1-2, k) = we(i, 2*mp1-2, k)-cr(mp1, np1, k)*vb(i, mn)
                                    we(i, 2*mp1-1, k) = we(i, 2*mp1-1, k)-ci(mp1, np1, k)*vb(i, mn)
                                end do
                                if (mod(nlat, 2) /= 0) then
                                    we(imid, 2*mp1-2, k) = we(imid, 2*mp1-2, k) &
                                        -cr(mp1, np1, k)*vb(imid, mn)
                                    we(imid, 2*mp1-1, k) = we(imid, 2*mp1-1, k) &
                                        -ci(mp1, np1, k)*vb(imid, mn)
                                end if
                            end do
                        end do
                    end if
                end do
        end select vector_symmetry_cases

        call util%assemble_transform(idvw, jdvw, idv, imid, &
            imm1, ityp, nlat, nlon, nt, v, ve, vo, w, we, wo, wrfft)

    end subroutine vhsgs_lower_utility_routine

    subroutine vhgsi_lower_utility_routine(nlat, imid, vb, wb, dthet, dwts, dpbar, work)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: imid
        real(wp),    intent(out) :: vb(imid, *)
        real(wp),    intent(out) :: wb(imid, *)
        real(wp),    intent(out) :: dthet(nlat)
        real(wp),    intent(out) :: dwts(nlat)
        real(wp),    intent(out) :: dpbar(imid, nlat, 3)
        real(wp),    intent(out) :: work(..)

        ! Local variables
        integer(ip)         :: i, id, ierror, ix, iy
        integer(ip)         :: m, mn, n, nm, np, nz
        real(wp)            :: abel, bbel, cbel, dcf
        type(SpherepackUtility) :: util

        !  Compute gauss points and weights
        call compute_gaussian_latitudes_and_weights(nlat, dthet, dwts, ierror)
        !
        !  Compute associated legendre functions
        !
        !    Compute m=n=0 legendre polynomials for all theta(i)
        !
        dpbar(:, 1, 1) = cos(PI/4)
        vb(:, 1) = ZERO
        wb(:, 1) = ZERO
        !
        !  main loop for remaining vb, and wb
        !
        do n=1, nlat-1
            nm = mod(n - 2, 3) + 1
            nz = mod(n - 1, 3) + 1
            np = mod(n, 3) + 1
            !
            !  Compute dpbar for m=0
            !
            call util%compute_fourier_coefficients(0, n, work)
            mn = get_index(0, n, nlat)
            do i=1, imid
                call util%compute_legendre_polys_from_fourier_coeff(0, n, dthet(i), work, dpbar(i, 1, np))
            end do
            !
            !  Compute dpbar for m=1
            !
            call util%compute_fourier_coefficients(1, n, work)
            mn = get_index(1, n, nlat)
            do i=1, imid
                call util%compute_legendre_polys_from_fourier_coeff(1, n, dthet(i), work, dpbar(i, 2, np))
            end do
            !
            !  Compute and store dpbar for m=2, n
            !
            if (2 <= n) then
                do m=2, n
                    abel = sqrt(real((2*n+1)*(m+n-2)*(m+n-3), kind=wp)/ &
                        real((2*n-3)*(m+n-1)*(m+n), kind=wp))
                    bbel = sqrt(real((2*n+1)*(n-m-1)*(n-m), kind=wp)/ &
                        real((2*n-3)*(m+n-1)*(m+n), kind=wp))
                    cbel = sqrt(real((n-m+1)*(n-m+2), kind=wp)/ &
                        real((m+n-1)*(m+n), kind=wp))
                    id = get_index(m, n, nlat)
                    if (m < n-1) then
                        dpbar(:, m+1, np) = abel*dpbar(:, m-1, nm)+bbel*dpbar(:, m+1, nm)-cbel*dpbar(:, m-1, np)
                    else
                        dpbar(:, m+1, np) = abel*dpbar(:, m-1, nm)-cbel*dpbar(:, m-1, np)
                    end if
                end do
            end if
            !
            !  Compute the derivative of the functions
            !
            ix = get_index(0, n, nlat)
            iy = get_index(n, n, nlat)
            do i=1, imid
                vb(i, ix) = -dpbar(i, 2, np)
                vb(i, iy) = dpbar(i, n, np)/sqrt(real(2*(n+1), kind=wp))
            end do
            !
            if (n /= 1) then
                dcf = sqrt(real(4*n*(n+1), kind=wp))
                do m=1, n-1
                    ix = get_index(m, n, nlat)
                    abel = sqrt(real((n+m)*(n-m+1), kind=wp))/dcf
                    bbel = sqrt(real((n-m)*(n+m+1), kind=wp))/dcf
                    do i=1, imid
                        vb(i, ix) = abel*dpbar(i, m, np)-bbel*dpbar(i, m+2, np)
                    end do
                end do
            end if
            !
            !     compute the vector harmonic w(theta) = m*pbar/cos(theta)
            !
            !     set wb=0 for m=0
            !
            ix = get_index(0, n, nlat)
            wb(1:imid, ix) = ZERO
            !
            !     compute wb for m=1, n
            !
            dcf = sqrt(real(2*n+1, kind=wp)/real(4*n*(n+1)*(n+n-1), kind=wp))

            do m=1, n
                ix = get_index(m, n, nlat)
                abel = dcf*sqrt(real((n+m)*(n+m-1), kind=wp))
                bbel = dcf*sqrt(real((n-m)*(n-m-1), kind=wp))
                if (m < n-1) then
                    wb(:, ix) = abel*dpbar(:, m, nz) + bbel*dpbar(:, m+2, nz)
                else
                    wb(:, ix) = abel*dpbar(:, m, nz)
                end if
            end do
        end do

    end subroutine vhgsi_lower_utility_routine

    pure function get_index(m, n, nlat) &
        result (return_value)

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

        return_value = m*nlat-(m*(m+1))/2+n+1

    end function get_index

end submodule vector_synthesis_gaussian_saved


function r8_gamma ( x )

!*****************************************************************************80
!
!! R8_GAMMA evaluates Gamma(X) for a real argument.
!
!  Discussion:
!
!    This function was originally named DGAMMA.
!
!    However, a number of Fortran compilers now include a library
!    function of this name.  To avoid conflicts, this function was
!    renamed R8_GAMMA.
!
!    This routine calculates the GAMMA function for a real argument X.
!    Computation is based on an algorithm outlined in reference 1.
!    The program uses rational functions that approximate the GAMMA
!    function to at least 20 significant decimal digits.  Coefficients
!    for the approximation over the interval (1,2) are unpublished.
!    Those for the approximation for 12 <= X are from reference 2.
!
!  Modified:
!
!    18 January 2008
!
!  Author:
!
!    Original FORTRAN77 version by William Cody, Laura Stoltz.
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!
!    William Cody,
!    An Overview of Software Development for Special Functions,
!    in Numerical Analysis Dundee, 1975,
!    edited by GA Watson,
!    Lecture Notes in Mathematics 506,
!    Springer, 1976.
!
!    John Hart, Ward Cheney, Charles Lawson, Hans Maehly,
!    Charles Mesztenyi, John Rice, Henry Thatcher,
!    Christoph Witzgall,
!    Computer Approximations,
!    Wiley, 1968,
!    LC: QA297.C64.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, the argument of the function.
!
!    Output, real ( kind = 8 ) R8_GAMMA, the value of the function.
!
  implicit none
!
!  Coefficients for minimax approximation over (12, INF).
!
  real    ( kind = 8 ), dimension ( 7 ) :: c = (/ &
   -1.910444077728D-03, &
    8.4171387781295D-04, &
   -5.952379913043012D-04, &
    7.93650793500350248D-04, &
   -2.777777777777681622553D-03, &
    8.333333333333333331554247D-02, &
    5.7083835261D-03 /)
  real    ( kind = 8 ) eps
  real    ( kind = 8 ) fact
  real    ( kind = 8 ) half
  integer ( kind = 4 ) i
  integer ( kind = 4 ) n
  real    ( kind = 8 ) one
  real    ( kind = 8 ) p(8)
  logical parity
  real    ( kind = 8 ) pi
  real    ( kind = 8 ) q(8)
  real    ( kind = 8 ) r8_gamma
  real    ( kind = 8 ) res
  real    ( kind = 8 ) sqrtpi
  real    ( kind = 8 ) sum
  real    ( kind = 8 ) twelve
  real    ( kind = 8 ) two
  real    ( kind = 8 ) x
  real    ( kind = 8 ) xbig
  real    ( kind = 8 ) xden
  real    ( kind = 8 ) xinf
  real    ( kind = 8 ) xminin
  real    ( kind = 8 ) xnum
  real    ( kind = 8 ) y
  real    ( kind = 8 ) y1
  real    ( kind = 8 ) ysq
  real    ( kind = 8 ) z
  real    ( kind = 8 ) zero
!
!  Mathematical constants
!
  data one /1.0D+00 /
  data half /0.5D+00/
  data twelve /12.0D+00/
  data two /2.0D+00 /
  data zero /0.0D+00/
  data sqrtpi /0.9189385332046727417803297D+00/
  data pi /3.1415926535897932384626434D+00/
!
!  Machine dependent parameters
!
  data xbig / 171.624D+00 /
  data xminin / 2.23D-308 /
  data eps / 2.22D-16 /
  data xinf /1.79D+308/
!
!  Numerator and denominator coefficients for rational minimax
!  approximation over (1,2).
!
  data p / -1.71618513886549492533811D+0,   2.47656508055759199108314D+01, &
           -3.79804256470945635097577D+02,  6.29331155312818442661052D+02, &
            8.66966202790413211295064D+02, -3.14512729688483675254357D+04, &
           -3.61444134186911729807069D+04,  6.64561438202405440627855D+04 /

  data q / -3.08402300119738975254353D+01,  3.15350626979604161529144D+02, &
           -1.01515636749021914166146D+03, -3.10777167157231109440444D+03, &
            2.25381184209801510330112D+04,  4.75584627752788110767815D+03, &
           -1.34659959864969306392456D+05, -1.15132259675553483497211D+05 /

  parity = .false.
  fact = one
  n = 0
  y = x
!
!  Argument is negative.
!
  if ( y <= zero ) then

    y = - x
    y1 = aint ( y )
    res = y - y1

    if ( res /= zero ) then

      if ( y1 /= aint ( y1 * half ) * two ) then
        parity = .true.
      end if

      fact = - pi / sin ( pi * res )
      y = y + one

    else

      res = xinf
      r8_gamma = res
      return

    end if

  end if
!
!  Argument is positive.
!
  if ( y < eps ) then
!
!  Argument < EPS.
!
    if ( xminin <= y ) then
      res = one / y
    else
      res = xinf
      r8_gamma = res
      return
    end if

  else if ( y < twelve ) then

    y1 = y
!
!  0.0 < argument < 1.0.
!
    if ( y < one ) then

      z = y
      y = y + one
!
!  1.0 < argument < 12.0.
!  Reduce argument if necessary.
!
    else

      n = int ( y ) - 1
      y = y - real ( n, kind = 8 )
      z = y - one

    end if
!
!  Evaluate approximation for 1.0 < argument < 2.0.
!
    xnum = zero
    xden = one
    do i = 1, 8
      xnum = ( xnum + p(i) ) * z
      xden = xden * z + q(i)
    end do

    res = xnum / xden + one
!
!  Adjust result for case  0.0 < argument < 1.0.
!
    if ( y1 < y ) then

      res = res / y1
!
!  Adjust result for case 2.0 < argument < 12.0.
!
    else if ( y < y1 ) then

      do i = 1, n
        res = res * y
        y = y + one
      end do

    end if

  else
!
!  Evaluate for 12.0 <= argument.
!
    if ( y <= xbig ) then

      ysq = y * y
      sum = c(7)
      do i = 1, 6
        sum = sum / ysq + c(i)
      end do
      sum = sum / y - y + sqrtpi
      sum = sum + ( y - half ) * log ( y )
      res = exp ( sum )

    else

      res = huge ( res )
      r8_gamma = res
      return

    end if

  end if
!
!  Final adjustments and return.
!
  if ( parity ) then
    res = - res
  end if

  if ( fact /= one ) then
    res = fact / res
  end if

  r8_gamma = res

  return

end function r8_gamma


PROGRAM LAPLACE
    INTEGER, PARAMETER :: XSIZE=41,YSIZE=41
    REAL(8), DIMENSION(1:XSIZE,1:YSIZE) :: PHIOLD,PHINEW,ORIPHI,ERROR
    REAL :: MAXDELTA
    REAL(8) :: ERRORSUM,PHISTAR,NSQ=XSIZE*YSIZE
    REAL :: OMEGA

    REAL(8), PARAMETER :: CONVERGENCE = EPSILON(ERRORSUM)
    INTEGER :: ITERATIONS = 0

    INTEGER :: I,J

    DO I=1,XSIZE
        DO J=1,YSIZE
            PHINEW(I,J) = (I*I-J*J)/(NSQ)
        END DO
    END DO

    PHINEW(2:XSIZE-1,2:YSIZE-1)=0

    ORIPHI(1:XSIZE,1:YSIZE) = PHINEW(1:XSIZE,1:YSIZE)

    open(10,file='sor_41.csv')

    OMEGA = 0.0

    HUNT_OMEGA:DO
        OMEGA = OMEGA+0.1
        ITERATIONS = 0
        PHINEW(1:XSIZE,1:YSIZE) = ORIPHI(1:XSIZE,1:YSIZE)
        GAUSS_ITERATION: DO
            ITERATIONS = ITERATIONS+1
            PHIOLD=PHINEW

            DO I=2,XSIZE-1
                DO J=2,YSIZE-1
                    PHINEW(I,J)=(0.25*(&
                        &PHINEW(I-1,J)+&
                        &PHINEW(I+1,J)+&
                        &PHINEW(I,J-1)+&
                        &PHINEW(I,J+1))-PHINEW(I,J))*OMEGA+&
                        &PHINEW(I,J)
                END DO
            END DO
            ERROR = PHIOLD-PHINEW
            ERRORSUM = SQRT(SUM(ERROR*ERROR)/NSQ)
            if (ITERATIONS>=100) EXIT GAUSS_ITERATION
         END DO GAUSS_ITERATION

         write(10,*) OMEGA, ERRORSUM
         if (OMEGA >= 1.0) EXIT HUNT_OMEGA
    END DO HUNT_OMEGA

    close(10)
END PROGRAM LAPLACE


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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 hwscyl(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
!                       elmbda, f, idimf, pertrb, ierror)
!
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n+1)
! ARGUMENTS
!
! PURPOSE                Solves a finite difference approximation
!                        to the helmholtz equation in cylindrical
!                        coordinates.  this modified helmholtz equation
!
!                          (1/r)(d/dr)(r(du/dr)) + (d/dz)(du/dz)
!
!                          + (lambda/r**2)u = f(r, z)
!
!                        results from the fourier transform of the
!                        three-dimensional poisson equation.
!
! USAGE                  call hwscyl(a, b, m, mbdcnd, bda, bdb, c, d, n,
!                                    nbdcnd, bdc, bdd, elmbda, f, idimf,
!                                    pertrb, ierror, w)
!
! ARGUMENTS
! ON INPUT               a, b
!                          the range of r, i.e., a <= r <= b.
!                          a must be less than b and a must be
!                          non-negative.
!
!                        m
!                          the number of panels into which the
!                          interval (a, b) is subdivided.  hence,
!                          there will be m+1 grid points in the
!                          r-direction given by r(i) = a+(i-1)dr,
!                          for i = 1, 2, ..., m+1, where dr = (b-a)/m
!                          is the panel width. m must be greater
!                          than 3.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at r = a and r = b.
!
!                          = 1  if the solution is specified at
!                               r = a and r = b.
!                          = 2  if the solution is specified at
!                               r = a and the derivative of the
!                               solution with respect to r is
!                               specified at r = b.
!                          = 3  if the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and r = b.
!                          = 4  if the derivative of the solution
!                               with respect to r is specified at
!                               r = a (see note below) and the
!                               solution is specified at r = b.
!                          = 5  if the solution is unspecified at
!                               r = a = 0 and the solution is
!                               specified at r = b.
!                          = 6  if the solution is unspecified at
!                               r = a = 0 and the derivative of the
!                               solution with respect to r is specified
!                               at r = b.
!
!                          if a = 0, do not use mbdcnd = 3 or 4,
!                          but instead use mbdcnd = 1, 2, 5, or 6  .
!
!                        bda
!                          a one-dimensional array of length n+1 that
!                          specifies the values of the derivative of
!                          the solution with respect to r at r = a.
!
!                          when mbdcnd = 3 or 4,
!                            bda(j) = (d/dr)u(a, z(j)), j = 1, 2, ..., n+1.
!
!                          when mbdcnd has any other value, bda is
!                          a dummy variable.
!
!                        bdb
!                          a one-dimensional array of length n+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to r at r = b.
!
!                          when mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dr)u(b, z(j)), j = 1, 2, ..., n+1.
!
!                          when mbdcnd has any other value, bdb is
!                          a dummy variable.
!
!                        c, d
!                          the range of z, i.e., c <= z <= d.
!                          c must be less than d.
!
!                        n
!                          the number of panels into which the
!                          interval (c, d) is subdivided.  hence,
!                          there will be n+1 grid points in the
!                          z-direction given by z(j) = c+(j-1)dz,
!                          for j = 1, 2, ..., n+1,
!                          where dz = (d-c)/n is the panel width.
!                          n must be greater than 3.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at z = c and z = d.
!
!                          = 0  if the solution is periodic in z,
!                               i.e., u(i, 1) = u(i, n+1).
!                          = 1  if the solution is specified at
!                               z = c and z = d.
!                          = 2  if the solution is specified at
!                               z = c and the derivative of
!                               the solution with respect to z is
!                               specified at z = d.
!                          = 3  if the derivative of the solution
!                               with respect to z is
!                               specified at z = c and z = d.
!                          = 4  if the derivative of the solution
!                               with respect to z is specified at
!                               z = c and the solution is specified
!                               at z = d.
!
!                        bdc
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to z at z = c.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dz)u(r(i), c), i = 1, 2, ..., m+1.
!
!                          when nbdcnd has any other value, bdc is
!                          a dummy variable.
!
!                        bdd
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative of
!                          the solution with respect to z at z = d.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) = (d/dz)u(r(i), d), i = 1, 2, ..., m+1
!
!                          when nbdcnd has any other value, bdd is
!                          a dummy variable.
!
!                        elmbda
!                          the constant lambda in the helmholtz
!                          equation.  if lambda > 0, a solution
!                          may not exist.  however, hwscyl will
!                          attempt to find a solution.  lambda must
!                          be zero when mbdcnd = 5 or 6  .
!
!                        f
!                          a two-dimensional array, of dimension at
!                          least (m+1)*(n+1), specifying values
!                          of the right side of the helmholtz
!                          equation and boundary data (if any).
!
!                          on the interior, f is defined as follows:
!                          for i = 2, 3, ..., m and j = 2, 3, ..., n
!                          f(i, j) = f(r(i), z(j)).
!
!                          on the boundaries f is defined as follows:
!                          for j = 1, 2, ..., n+1 and i = 1, 2, ..., m+1
!
!                          mbdcnd   f(1, j)            f(m+1, j)
!                          ------   ---------         ---------
!
!                            1      u(a, z(j))         u(b, z(j))
!                            2      u(a, z(j))         f(b, z(j))
!                            3      f(a, z(j))         f(b, z(j))
!                            4      f(a, z(j))         u(b, z(j))
!                            5      f(0, z(j))         u(b, z(j))
!                            6      f(0, z(j))         f(b, z(j))
!
!                          nbdcnd   f(i, 1)            f(i, n+1)
!                          ------   ---------         ---------
!
!                            0      f(r(i), c)         f(r(i), c)
!                            1      u(r(i), c)         u(r(i), d)
!                            2      u(r(i), c)         f(r(i), d)
!                            3      f(r(i), c)         f(r(i), d)
!                            4      f(r(i), c)         u(r(i), d)
!
!                          note:
!                          if the table calls for both the solution
!                          u and the right side f at a corner then
!                          the solution must be specified.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hwscyl.  this parameter is used to specify
!                          the variable dimension of f.  idimf must
!                          be at least m+1  .
!
!
! ON OUTPUT              f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (r(i), z(j)), i =1, 2, ..., m+1, j =1, 2, ..., n+1.
!
!                        pertrb
!                          if one specifies a combination of periodic,
!                          derivative, and unspecified boundary
!                          conditions for a poisson equation
!                          (lambda = 0), a solution may not exist.
!                          pertrb is a constant, calculated and
!                          subtracted from f, which ensures that a
!                          solution exists.  hwscyl then computes
!                          this solution, which is a least squares
!                          solution to the original approximation.
!                          this solution plus any constant is also
!                          a solution.  hence, the solution is not
!                          unique. the value of pertrb should be
!                          small compared to the right side f.
!                          otherwise, a solution is obtained to an
!                          essentially different problem.  this
!                          comparison should always be made to insure
!                          that a meaningful solution has been obtained.
!
!                        ierror
!                          an error flag which indicates invalid input
!                          parameters.  except for numbers 0 and 11,
!                          a solution is not attempted.
!
!                          =  0  no error.
!                          =  1  a < 0  .
!                          =  2  a >= b.
!                          =  3  mbdcnd < 1 or mbdcnd > 6  .
!                          =  4  c >= d.
!                          =  5  n <= 3
!                          =  6  nbdcnd < 0 or nbdcnd > 4  .
!                          =  7  a = 0, mbdcnd = 3 or 4  .
!                          =  8  a > 0, mbdcnd >= 5  .
!                          =  9  a = 0, lambda /= 0, mbdcnd >= 5  .
!                          = 10  idimf < m+1  .
!                          = 11  lambda > 0  .
!                          = 12  m <= 3
!                          = 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)
!
!                          since this is the only means of indicating
!                          a possibly incorrect call to hwscyl, the
!                          user should test ierror after the call.
!
!
! HISTORY                Written by Roland Sweet at NCAR in the late
!                        1970's.  Released on NCAR's public software
!                        libraries in January 1980.
!                        Revised in June 2004 by John Adams using
!                        Fortran 90 dynamically allocated workspace.
!
!
!
! ALGORITHM              The routine defines the finite difference
!                        equations, incorporates boundary data, and
!                        adjusts the right side of singular systems
!                        and then calls genbun to solve the system.
!
! TIMING                 For large  m and n, the operation count
!                        is roughly proportional to
!
!                          m*n*(log2(n)
!
!                        but also depends on input parameters nbdcnd
!                        and mbdcnd.
!
! ACCURACY               The solution process employed results in a loss
!                        of no more than three significant digits for n
!                        and m as large as 64.  more details about
!                        accuracy can be found in the documentation for
!                        subroutine genbun which is the routine that
!                        solves the finite difference equations.
!
! REFERENCES             Swarztrauber, P. and R. Sweet, "Efficient
!                        FORTRAN subprograms for the solution of
!                        elliptic equations"
!                        NCAR TN/IA-109, July, 1975, 138 pp.
!
submodule(centered_helmholtz_solvers) centered_cylindrical_solver

contains

    module subroutine hwscyl(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: mbdcnd
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: nbdcnd
        integer(ip), intent(in)    :: idimf
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: a
        real(wp),    intent(in)    :: b
        real(wp),    intent(in)    :: c
        real(wp),    intent(in)    :: d
        real(wp),    intent(in)    :: elmbda
        real(wp),    intent(out)   :: pertrb
        real(wp),    intent(in)    :: bda(:)
        real(wp),    intent(in)    :: bdb(:)
        real(wp),    intent(in)    :: bdc(:)
        real(wp),    intent(in)    :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)

        ! Local variables
        type(FishpackWorkspace)  :: workspace

        ! Check input arguments
        call hwscyl_check_input_arguments(a, b, m, mbdcnd, c, d, n, &
            nbdcnd, elmbda, idimf, ierror)

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

        ! Allocate memory
        call workspace%initialize_staggered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hwscyl_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, &
                nbdcnd, bdc, bdd, elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hwscyl

    subroutine hwscyl_check_input_arguments(a, b, m, mbdcnd, c, d, n, &
        nbdcnd, elmbda, idimf, ierror)

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

        if (a < ZERO) then
            ierror = 1
        else if (a >= b) then
            ierror = 2
        else if (mbdcnd <= 0 .or. mbdcnd >= 7) then
            ierror = 3
        else if (c >= d) then
            ierror = 4
        else if (n <= 3) then
            ierror = 5
        else if (nbdcnd <= (-1) .or. nbdcnd >= 5) then
            ierror = 6
        else if (a == ZERO .and. (mbdcnd == 3 .or. mbdcnd == 4)) then
            ierror = 7
        else if (a > ZERO .and. mbdcnd >= 5) then
            ierror = 8
        else if (a == ZERO .and. elmbda /= ZERO .and. mbdcnd >= 5) then
            ierror = 9
        else if (idimf < m + 1) then
            ierror = 10
        else if (m <= 3) then
            ierror = 12
        else
            ierror = 0
        end if

    end subroutine hwscyl_check_input_arguments

    subroutine hwscyl_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)

        ! Dummy arguments

        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        real(wp),    intent(inout) :: w(:)

        ! Local variables
        integer(ip) :: mp1, np1, np, mstart, mstop, munk, nstart, nstop, nunk
        integer(ip) :: id2, id3, id4, id5, id6, istart
        integer(ip) :: ij, i, j, k, l, nsp1, nstm1
        integer(ip) :: local_error_flag, i1
        real(wp)    :: dr, half_dr, dr2, dth, dth2
        real(wp)    :: a1, r, a2, s, s1, s2
        type(CenteredCyclicReductionUtility) :: util

        mp1 = m + 1
        dr = (b - a)/m
        half_dr = dr/2
        dr2 = dr**2
        np1 = n + 1
        dth = (d - c)/n
        dth2 = dth**2
        np = nbdcnd + 1

        ! Define range of indices i and j for unknowns u(i, j).
        mstart = 2
        mstop = m
        select case (mbdcnd)
            case (2)
                mstop = mp1
            case (3, 6)
                mstart = 1
                mstop = mp1
            case (4:5)
                mstart = 1
        end select

        munk = mstop - mstart + 1
        nstart = 1
        nstop = n
        select case (np)
            case (2)
                nstart = 2
            case (3)
                nstart = 2
                nstop = np1
            case (4)
                nstop = np1
        end select

        nunk = nstop - nstart + 1

        ! Define a, b, c coefficients in w-array.
        id2 = munk
        id3 = id2 + munk
        id4 = id3 + munk
        id5 = id4 + munk
        id6 = id5 + munk
        istart = 1
        a1 = TWO/dr2
        ij = 0

        if (mbdcnd==3 .or. mbdcnd==4) ij = 1

        if (mbdcnd > 4) then
            w(1) = 0.
            w(id2+1) = -TWO*a1
            w(id3+1) = TWO*a1
            istart = 2
            ij = 1
        end if

        do i = istart, munk
            r = a + real(i - ij, kind=wp)*dr
            j = id5 + i
            w(j) = r
            j = id6 + i
            w(j) = ONE/r**2
            w(i) = (r - half_dr)/(r*dr2)
            j = id3 + i
            w(j) = (r + half_dr)/(r*dr2)
            k = id6 + i
            j = id2 + i
            w(j) = (-a1) + elmbda*w(k)
        end do

        select case (mbdcnd)
            case (2)
                w(id2) = a1
            case (3, 6)
                w(id2) = a1
                w(id3+1) = a1*real(istart, kind=wp)
            case (4)
                w(id3+1) = a1*real(istart, kind=wp)
        end select

        select case (mbdcnd)
            case (1:2)
                a1 = w(1)
                f(2, nstart:nstop) = f(2, nstart:nstop) - a1*f(1, nstart:nstop)
            case (3:4)
                a1 = TWO*dr*w(1)
                f(1, nstart:nstop) = f(1, nstart:nstop) + a1*bda(nstart:nstop)
        end select

        select case (mbdcnd)
            case (1, 4:5)
                a1 = w(id4)
                f(m, nstart:nstop) = f(m, nstart:nstop) - a1*f(mp1, nstart:nstop)
            case (2:3, 6)
                a1 = TWO*dr*w(id4)
                f(mp1, nstart:nstop) = f(mp1, nstart:nstop) - a1*bdb(nstart:nstop)
        end select

        ! Enter boundary data for z-boundaries.
        a1 = ONE/dth2
        l = id5 - mstart + 1

        if (np /= 1) then
            select case (np)
                case (2:3)
                    f(mstart:mstop, 2) = f(mstart:mstop, 2) - a1*f(mstart:mstop, 1)
                case (4:5)
                    a1 = 2./dth
                    f(mstart:mstop, 1) = f(mstart:mstop, 1) + a1*bdc(mstart:mstop)
            end select

            a1 = ONE/dth2
            select case (np)
                case (2, 5)
                    f(mstart:mstop, n) = f(mstart:mstop, n) - a1*f(mstart:mstop, np1)
                case (3:4)
                    a1 = 2./dth
                    f(mstart:mstop, np1) = f(mstart:mstop, np1) - a1*bdd(mstart:mstop)
            end select
        end if

        if_block: block
            pertrb = ZERO
            if (elmbda >= ZERO) then
                if (elmbda /= ZERO) then
                    ierror = 11
                    return
                else
                    w(id5+1) = HALF*(w(id5+2)-half_dr)

                    select case (mbdcnd)
                        case (1:2, 4:5)
                            exit if_block
                        case (6)
                            w(id5+1) = HALF*w(id5+1)
                    end select

                    select case (np)
                        case (1)
                            a2 = ONE
                        case (2:3, 5)
                            exit if_block
                        case (4)
                            a2 = TWO
                    end select

                    k = id5 + munk
                    w(k) = HALF*(w(k-1)+half_dr)
                    s = ZERO

                    do i = mstart, mstop
                        s1 = ZERO
                        nsp1 = nstart + 1
                        nstm1 = nstop - 1
                        s1 = sum(f(i, nsp1:nstm1))
                        k = i + l
                        s = s + (a2*s1 + f(i, nstart)+f(i, nstop))*w(k)
                    end do

                    s2 = real(m, kind=wp)*a + (0.75_wp + real((m - 1)*(m + 1), kind=wp))*half_dr

                    if (mbdcnd == 3) s2 = s2 + 0.25_wp*half_dr

                    s1 = (TWO + a2*real(nunk-2, kind=wp))*s2

                    pertrb = s/s1
                    f(mstart:mstop, nstart:nstop) = &
                        f(mstart:mstop, nstart:nstop) - pertrb
                end if
            end if
        end block if_block

        w(:mstop-mstart+1) = w(:mstop-mstart+1)*dth2
        w(id2+1:mstop-mstart+1+id2) = w(id2+1:mstop-mstart+1+id2)*dth2
        w(id3+1:mstop-mstart+1+id3) = w(id3+1:mstop-mstart+1+id3)*dth2
        f(mstart:mstop, nstart:nstop) = f(mstart:mstop, nstart:nstop)*dth2
        w(1) = ZERO
        w(id4) = ZERO

        ! Solve the system of equations.
        local_error_flag = 0
        i1 = 1
        call util%genbun_lower_routine(nbdcnd, nunk, i1, munk, w(1:), w(id2+1:), w(id3+1:), &
            idimf, f(mstart:, nstart:), local_error_flag, w(id4+1:))

        if (local_error_flag /= 0) then
            error stop 'fishpack library: genbun_lower_routine call failed in hwscyl_lower_routine'
        end if

        if (nbdcnd == 0) f(mstart:mstop, np1) = f(mstart:mstop, 1)

    end subroutine hwscyl_lower_routine

end submodule centered_cylindrical_solver


program call_by_in_reference
    implicit none

    print *, factorial(5)

contains

    function factorial(arg) result(fac)
        implicit none
        integer, intent(in) :: arg
        integer :: fac, n

        n = arg
        fac = 1
        do while (n > 1)
            fac = fac*n
            n = n - 1
        end do
    end function factorial

end program call_by_in_reference