!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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_analysis_routines) vector_analysis_gaussian_grid_saved

contains

    ! Purpose:
    !
    !     subroutine vhags(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
    !                      mdab, ndab, wvhags, ierror)
    !
    !     subroutine vhags performs the vector spherical harmonic analysis
    !     on the vector field (v, w) and stores the result in the arrays
    !     br, bi, cr, and ci. v(i, j) and w(i, j) are the colatitudinal
    !     (measured from the north pole) and east longitudinal components
    !     respectively, located at the gaussian colatitude point theta(i)
    !     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
    !     representation of (v, w) is given at output parameters v, w in
    !     subroutine vhses.
    !
    !     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 analysis
    !                 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 analysis
    !                 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 analysis
    !                 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analysis is performed on the northern
    !                 hemisphere only.  i.e., if nlat is odd the analysis
    !                 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 analysis 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 analyses.  in the program that calls vhags,
    !            the arrays v, w, br, bi, cr, and ci can be three dimensional
    !            in which case multiple analyses will be performed.
    !            the third index is the analysis index which assumes the
    !            values k=1, ..., nt.  for a single analysis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that all the arrays are two
    !            dimensional.
    !
    !     v, w    two or three dimensional arrays (see input parameter nt)
    !            that contain the vector function to be analyzed.
    !            v is the colatitudnal component and w is the east
    !            longitudinal component. v(i, j), w(i, j) contain the
    !            components at the gaussian colatitude point theta(i)
    !            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
    !            are defined above at the input parameter ityp.
    !
    !     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 vhags. jdvw must be at least nlon.
    !
    !     mdab   the first dimension of the arrays br, bi, cr, and ci as it
    !            appears in the program that calls vhags. 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 vhags. ndab must be at
    !            least nlat.
    !
    !     wvhags an array which must be initialized by subroutine vhgsi.
    !            once initialized, wvhags can be used repeatedly by vhags
    !            as long as nlon and nlat remain unchanged.  wvhags must
    !            not be altered between calls of vhags.
    !
    !     lvhags the dimension of the array wvhags as it appears in the
    !            program that calls vhags. 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 lvhags must be at least
    !
    !            l1*l2(nlat+ nlat-l1+1)+ nlon + 15
    !
    !        ??? (nlat + 1)*(nlat + 1)*nlat/2 + nlon + 15
    !
    !     output parameters
    !
    !     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
    !            in the discription of subroutine vhses. br(mp1, np1),
    !            bi(mp1, np1), cr(mp1, np1), and ci(mp1, np1) are computed
    !            for mp1=1, ..., mmax and np1=mp1, ..., nlat except for np1=nlat
    !            and odd mp1. mmax=min(nlat, nlon/2) if nlon is even or
    !            mmax=min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     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 lvhags
    !
    module subroutine vhags(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
        mdab, ndab, wvhags, 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(in)  :: v(idvw, jdvw, nt)
        real(wp),    intent(in)  :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(out) :: br(mdab, ndab, nt)
        real(wp),    intent(out) :: bi(mdab, ndab, nt)
        real(wp),    intent(out) :: cr(mdab, ndab, nt)
        real(wp),    intent(out) :: ci(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvhags(:)
        integer(ip), intent(out) :: ierror

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

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

        ! Check calling arguments
        call util%check_vector_analysis_inputs(nlat, nlon, ityp, idvw, jdvw, &
            mdab, ndab, nt, required_wavetable_size, wvhags, ierror)

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

        select case(ityp)
            case(0:2)
                ist = imid
                idv = nlat
            case default
                ist = 0
                idv = imid
        end select

        lnl = nt*idv*nlon

        ! Set required workspace size
        lwork = 2*lnl+idv*nlon

        block
            real(wp) :: work(lwork)

            ! Compute workspace pointers
            workspace_indices = get_vhags_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 vhags_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, wvhags(jw1:), wvhags(jw2:), wvhags(jw3:))
            end associate
        end block

    end subroutine vhags

    ! Purpose:
    !
    !     subroutine vhagsi(nlat, nlon, wvhags, ierror)
    !
    !     subroutine vhagsi initializes the array wvhags which can then be
    !     used repeatedly by subroutine vhags 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.
    !
    !     lvhags the dimension of the array wvhags as it appears in the
    !            program that calls vhagsi. lvhags must be at least
    !
    !               3*nlat*(nlat + 1)+2  (required by vhagsi)
    !
    !     output parameters
    !
    !     wvhags an array which is initialized for use by subroutine vhags.
    !            once initialized, wvhags can be used repeatedly by vhags
    !            as long as nlat and nlon remain unchanged.  wvhags must not
    !            be altered between calls of vhags.
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lvhags
    !
    module subroutine vhagsi(nlat, nlon, wvhags, ierror)

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

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

        imid = (nlat + 1)/2
        lmn = (nlat*(nlat + 1))/2
        required_wavetable_size = 2*(imid*lmn)+ nlon + 15

        !  Check calling arguments
        if (nlat < 3) then
            ierror = 1
        else if (nlon < 1) then
            ierror = 2
        else if (size(wvhags) < required_wavetable_size) then
            ierror = 3
        else
            ierror = 0
        end if

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

        !  Compute workspace indices
        workspace_indices = get_vhagsi_workspace_indices(nlat, imid, lmn)

        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) &
            )

            ! Set required workspace size
            ldwork = (nlat*(3*nlat+9)+2)/2
            block
                real(wp) :: dwork(ldwork)

                call precompute_associated_legendre_functions( &
                    nlat, imid, wvhags(jw1:), wvhags(jw2:), &
                    dwork(iw1:), dwork(iw2:), dwork(iw3:), dwork(iw4:))

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

    end subroutine vhagsi

    pure function get_vhags_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 wvhags 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_vhags_workspace_indices

    subroutine vhags_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(in)  :: v(idvw, jdvw, nt)
        real(wp),    intent(in)  :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(out) :: br(mdab, ndab, nt)
        real(wp),    intent(out) :: bi(mdab, ndab, nt)
        real(wp),    intent(out) :: cr(mdab, ndab, nt)
        real(wp),    intent(out) :: 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, mp1, mp2
        integer(ip) :: odd_stride, even_stride, np1
        type(VectorAnalysisUtility) :: util

        call util%analysis_setup(idvw, jdvw, mdab, ndab, &
            bi, br, ci, cr, even_stride, idv, imid, imm1, ityp, &
            mmax, nlat, nlon, nt, odd_stride,  v, ve, vo, w, we, wo, wrfft)

        vector_symmetry_cases: select case (ityp)
            case (0)

                ! case ityp = 0,  no symmetries

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

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*vo(i, 1, k)
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                main_loop_case_0: 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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-2, k) &
                                        +wb(i, np1+mb)*we(i, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-1, k) &
                                        -wb(i, np1+mb)*we(i, 2*mp1-2, k)
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-2, k) &
                                        +wb(i, np1+mb)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-1, k) &
                                        -wb(i, np1+mb)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

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

                    if (mp2 > even_stride) cycle main_loop_case_0

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*wo(i, 2*mp1-2, k)
                                cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) cycle main_loop_case_0

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                            cr(mp1, np1, k) = cr(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do main_loop_case_0
            case (1)
                !
                !  case ityp=1 ,  no symmetries but cr and ci equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*ve(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-2, k) &
                                        +wb(i, np1+mb)*we(i, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-1, k) &
                                        -wb(i, np1+mb)*we(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then
                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    br(mp1, np1, k) = br(mp1, np1, k)+wb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                                    bi(mp1, np1, k) = bi(mp1, np1, k)-wb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (2)
                !
                !  case ityp=2 ,  no symmetries but br and bi equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*we(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-2, k) &
                                        +wb(i, np1+mb)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-1, k) &
                                        -wb(i, np1+mb)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

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

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (3)
                !
                !  case ityp=3 ,  v even , w odd
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*ve(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                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 i=1, imm1
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-2, k) &
                                        +wb(i, np1+mb)*ve(i, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-1, k) &
                                        -wb(i, np1+mb)*ve(i, 2*mp1-2, k)
                                end do
                            end do
                        end do

                        if (mod(nlat, 2) /= 0) then

                            do k=1, nt
                                do np1=mp1, odd_stride, 2
                                    cr(mp1, np1, k) = cr(mp1, np1, k)+wb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                                    ci(mp1, np1, k) = ci(mp1, np1, k)-wb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                                end do
                            end do
                        end if
                    end if

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (4)
                !
                !  case ityp=4 ,  v even, w odd, and cr and ci equal 0.
                !
                ! case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*ve(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*nlat-(m*(m + 1))/2
                    mp2 = mp1+1

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*wo(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*ve(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*wo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)+vb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (5)
                !
                !  case ityp=5   v even, w odd, and br and bi equal zero
                !
                ! case m=0
                !
                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*wo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*nlat-(m*(m + 1))/2
                    mp2 = mp1+1

                    if (mp1 > odd_stride) return

                    do  k=1, nt
                        do  i=1, imm1
                            do  np1=mp1, odd_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*ve(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*wo(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*ve(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp1, odd_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)+wb(imid, np1+mb)*ve(imid, 2*mp1-1, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-wb(imid, np1+mb)*ve(imid, 2*mp1-2, k)
                        end do
                    end do
                end do
            case (6)
                !
                !  case ityp=6 ,  v odd , w even
                !
                ! case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*we(i, 1, k)
                        end do
                    end do
                end do

                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

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

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do k=1, nt
                        do np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
            case (7)
                !
                !  case ityp=7   v odd, w even, and cr and ci equal zero
                !
                !    case m=0
                !
                do k=1, nt
                    do i=1, imm1
                        do np1=3, odd_stride, 2
                            br(1, np1, k) = br(1, np1, k)+vb(i, np1)*vo(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*nlat-(m*(m + 1))/2
                    mp2 = mp1+1

                    if (mp1 > odd_stride) exit

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp1, odd_stride, 2
                                br(mp1, np1, k) = br(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*we(i, 2*mp1-1, k)
                                bi(mp1, np1, k) = bi(mp1, np1, k)+vb(i, np1+mb)*vo(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*we(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do  k=1, nt
                        do np1=mp1, odd_stride, 2
                            br(mp1, np1, k) = br(mp1, np1, k)+wb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                            bi(mp1, np1, k) = bi(mp1, np1, k)-wb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                        end do
                    end do
                end do
            case (8)
                !
                !  case ityp=8   v odd, w even, and both br and bi equal zero
                !
                ! case m=0
                !
                do k=1, nt
                    do i=1, imid
                        do np1=2, even_stride, 2
                            cr(1, np1, k) = cr(1, np1, k)-vb(i, np1)*we(i, 1, k)
                        end do
                    end do
                end do
                !
                !  case m = 1 through nlat-1
                !
                if (mmax < 2) return

                do mp1=2, mmax
                    m = mp1-1
                    mb = m*nlat-(m*(m + 1))/2
                    mp2 = mp1+1

                    if (mp2 > even_stride) return

                    do k=1, nt
                        do i=1, imm1
                            do np1=mp2, even_stride, 2
                                cr(mp1, np1, k) = cr(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-2, k) &
                                    +wb(i, np1+mb)*vo(i, 2*mp1-1, k)
                                ci(mp1, np1, k) = ci(mp1, np1, k)-vb(i, np1+mb)*we(i, 2*mp1-1, k) &
                                    -wb(i, np1+mb)*vo(i, 2*mp1-2, k)
                            end do
                        end do
                    end do

                    if (mod(nlat, 2) == 0) return

                    do  k=1, nt
                        do  np1=mp2, even_stride, 2
                            cr(mp1, np1, k) = cr(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-2, k)
                            ci(mp1, np1, k) = ci(mp1, np1, k)-vb(imid, np1+mb)*we(imid, 2*mp1-1, k)
                        end do
                    end do
                end do
        end select vector_symmetry_cases

    end subroutine vhags_lower_utility_routine

    pure function get_vhagsi_workspace_indices(nlat, imid, lmn) &
        result (return_value)

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

        ! Set workspace pointers for indices
        associate (i => return_value)
            i(1) = 1
            i(2) = i(1)+imid*lmn
            i(3) = i(2)+imid*lmn
            i(4) = 1
            i(5) = i(4)+ nlat
            i(6) = i(5)+ nlat
            i(7) = i(6)+3*imid*nlat
        end associate

    end function get_vhagsi_workspace_indices

    ! Purpose:
    !
    ! Computes associated legendre functions.
    subroutine precompute_associated_legendre_functions(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, local_error_flag, id, ix, iy
        integer(ip)         :: m, mn, n, nm, np, nz
        real(wp)            :: abel, bbel, cbel, dcf
        type(SpherepackUtility) :: util

        !  Compute gaussian grid
        call compute_gaussian_latitudes_and_weights(nlat, dthet, dwts, local_error_flag)

        ! Set 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
        main_loop: 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))/ &
                        real((2*n - 3)*(m + n - 1)*(m + n)))
                    bbel = sqrt(real((2*n + 1)*(n - m - 1)*(n - m))/ &
                        real((2*n - 3)*(m + n - 1)*(m + n)))
                    cbel = sqrt(real((n - m + 1)*(n - m + 2))/ &
                        real((m + n - 1)*(m + n)))
                    id = get_index(m, n, nlat)

                    if (n - 1 <= m) then
                        dpbar(1:imid, m + 1, np) = &
                            abel*dpbar(1:imid, m - 1, nm)-cbel*dpbar(1:imid, m - 1, np)
                    else
                        dpbar(1:imid, m + 1, np) = &
                            abel*dpbar(1:imid, m - 1, nm)+bbel*dpbar(1:imid, m + 1, nm) &
                            -cbel*dpbar(1:imid, 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)
            vb(1:imid, ix) = -dpbar(1:imid, 2, np)*dwts(1:imid)
            vb(1:imid, iy) = dpbar(1:imid, n, np)/sqrt(real(2*(n + 1), kind=wp))*dwts(1:imid)

            select case (n)
                case (1)
                    ! 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
                case default
                    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
                        vb(1:imid, ix) = &
                            (abel * dpbar(1:imid, m, np) - bbel * dpbar(1:imid, m + 2, np))&
                            * dwts(1:imid)
                    end do
            end select

            ! 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 (n - 1 <= m) then
                    wb(1:imid, ix) = abel * dpbar(1:imid, m, nz) * dwts(1:imid)
                else
                    wb(1:imid, ix) = &
                        (abel * dpbar(1:imid, m, nz) + bbel * dpbar(1:imid, m + 2, nz))&
                        * dwts(1:imid)
                end if
            end do
        end do main_loop

    end subroutine precompute_associated_legendre_functions

    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_analysis_gaussian_grid_saved


      double precision function dist (r0, r1)
c     find distance between cartesian points r0 and r1
      implicit double precision (a-h, o-z)
      dimension r0(3), r1(3)
      dist = 0
      do 10  i = 1, 3
         dist = dist + (r0(i) - r1(i))**2
   10 continue
      dist = sqrt (dist)
      return
      end


	subroutine fastf(Fr,Fi,n)
c
c	n  = the number of data points=2**m
c	Fr = the real data set
c	Fi is the imaginary part of data set (=0.0 if only real)
c
c	first compute m
c
	real*4 Fr(n), Fi(n), Gr, Gi, Er, Ei, Eu, Ez
	m=0
	kd=n
 1	kd=kd/2
	m=m+1
	if (kd .ge. 2) go to 1
	nd2=n/2
	nm1=n-1
	l=1
c
c	shuffle input data in binary digit reverse order
c
	do 4 k=1,nm1
	if (k .ge. l) go to 2
	Gr=Fr(l)
	Gi=Fi(l)
	Fr(l)=Fr(k)
	Fi(l)=Fi(k)
	Fr(k)=Gr
	Fi(k)=Gi
 2	nnd2=nd2
 3	if(nnd2 .ge. l) go to 4
	l=l-nnd2
	nnd2=nnd2/2
	go to 3
 4	l=l+nnd2
	pi=3.14159265
c
c	first arrange accounting of m stage
c
	do 6 j=1,m
	nj=2**j
	njd2=nj/2
	Eu=1.0
	Ez=0.0
	Er=cos(-pi/njd2)
	Ei=sin(-pi/njd2)
c
c	compute fourie transform in each m stage
c
	do 6 it=1,njd2
	do 5 iw=it,n,nj
	iwj=iw+njd2
	Gr=Fr(iwj)*Eu-Fi(iwj)*Ez
	Gi=Fi(iwj)*Eu+Fr(iwj)*Ez
	Fr(iwj)=Fr(iw)-Gr
	Fi(iwj)=Fi(iw)-Gi
	Fr(iw) =Fr(iw)+Gr
 5	Fi(iw) =Fi(iw)+Gi
	Seu=Eu
	Eu=Seu*Er-Ez*Ei
 6	Ez=Ez*Er+Seu*Ei
	Return
	End


! ====================================================================================
!                           3D BELTRAMI FLOW
!
! Beltrami flow:
!     u(x, y, z) = (k^2 + l^2)^(-1) * [k*m*sin(mz) - l*alpha*cos(m*z) * sin(k*x + l*y)]
!     v(x, y, z) = (k^2 + l^2)^(-1) * [l*m*sin(mz) + k*alpha*cos(m*z) * sin(k*x + l*y)]
!     w(x, y, z) = cos(m*z) * cos(k*x + l*y)
! The vorticity of this flow is
!    xi(x, y, z) = alpha * u(x, y, z)
!   eta(x, y, z) = alpha * v(x, y, z)
!  zeta(x, y, z) = alpha * w(x, y, z)
!
!                   The code uses following variable names:
!                       beltrami_flow%k = k
!                       beltrami_flow%l = l
!                       beltrami_flow%m = m
! ====================================================================================
module beltrami_3d
    use netcdf_writer
    use constants, only : pi, f12, zero, one, two
    implicit none

    private
        type beltrami_type
            integer          :: k, l, m
        end type beltrami_type

        type(beltrami_type) :: beltrami_flow

        double precision :: fk2l2, kk, ll, mm, alpha

        integer :: x_vor_id, y_vor_id, z_vor_id

        double precision, parameter :: hpi = f12 * pi

    public :: get_flow_vorticity,   &
              beltrami_init,        &
              beltrami_flow

    contains
        subroutine beltrami_init(ncid, dimids, nx, ny, nz, origin, dx)
            integer,          intent(inout) :: ncid
            integer,          intent(in)    :: dimids(:)
            integer,          intent(in)    :: nx, ny, nz
            double precision, intent(in)    :: origin(3)
            double precision, intent(in)    :: dx(3)
            double precision                :: pos(3)
            double precision                :: vortg(0:nz, 0:ny-1, 0:nx-1, 3)
            integer                         :: i, j, k

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='x_vorticity',                  &
                                       long_name='x vorticity component',   &
                                       std_name='',                         &
                                       unit='1/s',                          &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=x_vor_id)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='y_vorticity',                  &
                                       long_name='y vorticity component',   &
                                       std_name='',                         &
                                       unit='1/s',                          &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=y_vor_id)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='z_vorticity',                  &
                                       long_name='z vorticity component',   &
                                       std_name='',                         &
                                       unit='1/s',                          &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=z_vor_id)

            call close_definition(ncid)

            kk = dble(beltrami_flow%k)
            ll = dble(beltrami_flow%l)
            mm = dble(beltrami_flow%m)
            alpha = dsqrt(kk ** 2 + ll ** 2 + mm ** 2)
            fk2l2 = alpha / dble(beltrami_flow%k ** 2 + beltrami_flow%l ** 2)

            do i = 0, nx - 1
                do j = 0, ny - 1
                    do k = 0, nz
                        pos = origin + dx * dble((/i, j, k/))
                        vortg(k, j, i, :) = get_flow_vorticity(pos)
                    enddo
                enddo
            enddo

            call write_netcdf_dataset(ncid, x_vor_id, vortg(:, :, :, 1))
            call write_netcdf_dataset(ncid, y_vor_id, vortg(:, :, :, 2))
            call write_netcdf_dataset(ncid, z_vor_id, vortg(:, :, :, 3))

        end subroutine beltrami_init

        function get_flow_vorticity(pos) result(omega)
            double precision, intent(in) :: pos(3)
            double precision             :: x, y, z
            double precision             :: omega(3)
            double precision             :: cosmz, sinmz, sinkxly, coskxly

            x = pos(1)
            y = pos(2)
            z = pos(3)

            cosmz = dcos(mm * z)
            sinmz = dsin(mm * z)
            sinkxly = dsin(kk * x + ll * y)
            coskxly = dcos(kk * x + ll * y)

            omega(1) = fk2l2 * (kk * mm * sinmz - ll * alpha * cosmz) * sinkxly
            omega(2) = fk2l2 * (ll * mm * sinmz + kk * alpha * cosmz) * sinkxly
            omega(3) = alpha * cosmz * coskxly

        end function get_flow_vorticity

end module beltrami_3d


C
C $Id: mdgcog.f,v 1.8 2008-09-18 00:42:17 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDGCOG (CLAT,CLON,CRAD,ALAT,ALON,NPTS)
C
C This routine returns, in the arrays ALAT and ALON, the latitudes and
C longitudes of NPTS points on the surface of the globe, all of them at
C the great-circle distance CRAD from the point (CLAT,CLON), defining a
C circle.  The last point returned is a copy of the first.
C
        DOUBLE PRECISION CLAT,CLON,CRAD,ALAT(*),ALON(*)
        INTEGER          NPTS
C
C Declare common block containing math constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Declare local variables.
C
        DOUBLE PRECISION RLAT,RLON,UCRD,VCRD,WCRD
        INTEGER          IPNT
C
C Points on a circle around the North Pole are rotated to lie around
C the point at latitude CLAT and longitude CLON.
C
        RLAT=DTOR*(90.-CRAD)
C
        DO 101 IPNT=1,NPTS
          RLON=DTOR*360.D0*(DBLE(IPNT-1)/DBLE(NPTS-1))
          UCRD=COS(RLAT)*COS(RLON)
          VCRD=COS(RLAT)*SIN(RLON)
          WCRD=SIN(RLAT)
          CALL MDRITD (2,90.D0-CLAT,UCRD,VCRD,WCRD)
          CALL MDRITD (3,      CLON,UCRD,VCRD,WCRD)
          ALAT(IPNT)=RTOD*ASIN(MAX(-1.D0,MIN(+1.D0,WCRD)))
          ALON(IPNT)=RTOD*ATAN2(VCRD,UCRD)
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


module vel_mod
  implicit none
  private
  public :: You_star, R_ohms, WindF, Stab, StabH, FStabH, FStabM, ResTrn, MOL

  real :: MOL = 0.0

  contains
!  Function Definitions for Vel

    real pure function You_star (w,Height,Roughness,Stability,R_Karman)
      real, intent(in) :: w, Height, Roughness, Stability, R_Karman

      You_star = R_Karman * w / ((ALOG(Height / Roughness) + Stability))

    end function You_star

    real pure function R_ohms (Friction,Height,Roughness,Stability,Karman)
      real, intent(in) :: Friction, Height, Roughness, Stability, Karman
      real, parameter :: Konst = 0.74

      R_ohms = Konst * (ALOG(Height/Roughness) + Stability)/(Karman * Friction)

    end function R_ohms

    real pure function WindF (Star,Height,Roughness,Stability,R_Karman)
      real, intent(in) :: Star, Height, Roughness, Stability, R_Karman

      WindF = (Star / R_Karman)*(ALOG(Height/Roughness) + Stability)

    end function WindF

    real pure function Stab (Height,MOL)
      real, intent(in) :: Height, MOL

      Stab = (1 - 15 * Height / MOL)**0.25

    end function Stab

    real pure function StabH (Height, MOL)
      real, intent(in) :: Height, MOL

      StabH = (1 - 9 * Height / MOL)**0.5

    end function StabH

    real pure function FstabH (Par1,Par2)
      real, intent(in) :: Par1, Par2

      FstabH = 2 * ALOG(( Par1 + 1) / (Par2 + 1))

    end function FstabH

    real pure function FstabM (Par1,Par2)
      real, intent(in) :: Par1, Par2

      FStabM = ALOG (((Par1**2 + 1 ) * (Par1 + 1 )**2 ) /                   &
                    ((Par2 + 1 ) * (Par2 + 1 )**2 )) + 2 *                  &
                    ( ATAN(Par2) - ATAN(Par1))

    end function FstabM

    real pure function ResTrn (Star,Roughness,Par3,R_KARMAN)
      real, intent(in) :: Star, Roughness, Par3, R_KARMAN

      RESTRN = (ALOG(R_KARMAN* Star*Roughness+Par3) - ALOG(Par3)) / (R_KARMAN  * Star)

    end function ResTrn

end module vel_mod


!| The `numeric_integer` module provides constants and procedures related to integer.
!
! The constants include minimum and maximum values of the integer types provided by the Fortran standard
! and parameters for specifying the result kind of the intrinsic procedures like `transfer`.
!
! The procedures include functions to get the number of digits of an integer variable,
! check whether an integer is positive/negative, and convert an integer to a string in a specified format.
!
module numeric_integer
    use, intrinsic :: iso_fortran_env
    implicit none
    private
    public :: get_digit
    public :: to_string
    public :: is_positive
    public :: is_negative

    !&<
    integer(int8) , public, parameter :: result_type_int8   = 0_int8
        !! A constant to represent 1-byte signed integer.
        !! This constant is used to specify the result kind of the intrinsic functions.
    integer(int16), public, parameter :: result_type_int16  = 0_int16
        !! A constant to represent 2-byte signed integer.
        !! This constant is used to specify the result kind of the intrinsic functions.
    integer(int32), public, parameter :: result_type_int32  = 0_int32
        !! A constant to represent 4-byte signed integer.
        !! This constant is used to specify the result kind of the intrinsic functions.
    integer(int64), public, parameter :: result_type_int64  = 0_int64
        !! A constant to represent 8-byte signed integer.
        !! This constant is used to specify the result kind of the intrinsic functions.
    !&>

    integer(int8), public, parameter :: Int8_Max = int(Z'7F', int8)
        !! The maximum value of 1-byte signed integer `=+127`
    integer(int8), public, parameter :: Int8_Min = int(-Int8_Max-1, int8) !&
        !! The minimum value of 1-byte signed integer `=-128`

    integer(int16), public, parameter :: Int16_Max = int(Z'7FFF', int16)
        !! The maximum value of 2-byte signed integer `=+32,767`
    integer(int16), public, parameter :: Int16_Min = int(-Int16_Max-1, int16) !&
        !! The minimum value of 2-byte signed integer `=-32,768`

    integer(int32), public, parameter :: Int32_Max = int(Z'7FFFFFFF', int32)
        !! The maximum value of 4-byte signed integer `=+2,147,483,647`
    integer(int32), public, parameter :: Int32_Min = int(-Int32_Max-1, int32) !&
        !! The minimum value of 4-byte signed integer `=-2,147,483,648`

    integer(int64), public, parameter :: Int64_Max = int(Z'7FFFFFFFFFFFFFFF', int64)
        !! The maximum value of 8-byte signed integer `=+9,223,372,036,854,775,807`
    integer(int64), public, parameter :: Int64_Min = int(-Int64_Max-1, int64) !&
        !! The minimum value of 8-byte signed integer `=-9,223,372,036,854,775,808`

    !| Returns a number of digits of an integer.
    interface get_digit
        procedure :: get_digit_int8
        procedure :: get_digit_int16
        procedure :: get_digit_int32
        procedure :: get_digit_int64
    end interface

    !| Returns a string created by converting an integer.
    interface to_string
        procedure :: integer32_to_string_with_format
        procedure :: integer32_to_string_with_digits
    end interface

    !| Returns `.true.` if an integer is positive, including 0.
    interface is_positive
        procedure :: is_positive_int8
        procedure :: is_positive_int16
        procedure :: is_positive_int32
        procedure :: is_positive_int64
    end interface

    !| Returns `.true.` if an integer is negative, not including 0.
    interface is_negative
        procedure :: is_negative_int8
        procedure :: is_negative_int16
        procedure :: is_negative_int32
        procedure :: is_negative_int64
    end interface

    character(*), private, parameter :: default_integer_format = '(i0.0)'

    integer(int32), private, parameter :: MaxLength_of_IOMessage = 255
    integer(int32), private, parameter :: MaxLength_of_Buffer = 255

contains
    !| Gets the number of digits of 1-byte integer.
    pure function get_digit_int8(i8) result(digits)
        implicit none
        !&<
        integer(int8), intent(in)    :: i8
            !! 1-byte integer
        !&>
        integer(int32) :: digits
            !! A number of digits in `i8` value

        integer(int32) :: i

        i = abs(i8)
        digits = 1

        do while (i >= 10)
            i = i/10
            digits = digits + 1
        end do
    end function get_digit_int8

    !| Gets the number of digits of 2-byte integer.
    pure function get_digit_int16(i16) result(digits)
        implicit none
        !&<
        integer(int16), intent(in)  :: i16
            !! 2-byte integer
        !&>
        integer(int32) :: digits
            !! A number of digits in `i16` value

        integer(int32) :: i

        i = abs(i16)
        digits = 1

        do while (i >= 10)
            i = i/10
            digits = digits + 1
        end do
    end function get_digit_int16

    !| Gets the number of digits of 4-byte integer.
    pure function get_digit_int32(i32) result(digits)
        implicit none
        !&<
        integer(int32), intent(in)  :: i32
            !! 4-byte integer
        !&>
        integer(int32) :: digits
            !! A number of digits in `i32` value

        integer(int32) :: i

        i = abs(i32)
        digits = 1

        do while (i >= 10)
            i = i/10
            digits = digits + 1
        end do
    end function get_digit_int32

    !| Gets the number of digits of 8-byte integer.
    pure function get_digit_int64(i64) result(digits)
        implicit none
        !&<
        integer(int64), intent(in) :: i64
            !! 8-byte integer
        !&>
        integer(int32) :: digits
            !! A number of digits in `i64` value

        integer(int64) :: i

        i = abs(i64)
        digits = 1

        do while (i >= 10)
            i = i/10
            digits = digits + 1
        end do
    end function get_digit_int64

    !------------------------------------------------------------------!
    !| Converts a 4-byte integer to a string based on a format passed as an argument.
    ! When the format is not given, `'(i0.0)'` is used as the format.
    ! A zero-length string is returned when the convert is failed.
    function integer32_to_string_with_format(i32, format) result(str)
        implicit none
        !&<
        integer(int32)  , intent(in)            :: i32
            !! 4-byte integer
        character(*)    , intent(in), optional  :: format
            !! format for string conversion
        !&>
        character(:), allocatable :: str
            !! a converted string

        character(MaxLength_of_Buffer) :: buffer
        integer :: IOStatus
        character(MaxLength_of_IOMessage) :: IOMessage

        ! The validation of the format is not checked.
        if (present(format)) then
            write (buffer, format, iostat=IOStatus, iomsg=IOMessage) i32
        else
            write (buffer, default_integer_format, iostat=IOStatus, iomsg=IOMessage) i32
        end if

        ! The convert is failed
        if (IOStatus /= 0) then
            write (error_unit, '(A)') trim(IOMessage)
            buffer = "" ! returns a zero-length string
        end if

        str = trim(buffer)
    end function integer32_to_string_with_format

    !|A function converts a 4-byte integer to a string based on the number of digits and zero-filling digits passed as arguments.
    ! When the format is not given, `'(i0.0)'` is used as the format.
    ! A zero-length string is returned when the convert is failed.
    function integer32_to_string_with_digits(i32, digit, zerofill) result(str)
        implicit none
        !&<
        integer(int32), intent(in)              :: i32
            !! 4-byte integer
        integer(int32), intent(in)              :: digit
            !! The number of digits in the converted string
        integer(int32), intent(in), optional    :: zerofill
            !! The number of digits to fill with zeros
        !&>
        character(:), allocatable :: str
           !! a converted string

        integer(int32), parameter :: Extra_Digits_Sign = 1

        character(:), allocatable :: fmt
        character(:), allocatable :: str_digits
        character(:), allocatable :: str_zfill

        ! construct format string
        if (is_positive(i32)) then
            str_digits = integer32_to_string_with_format(digit)
        else
            str_digits = integer32_to_string_with_format(digit + Extra_Digits_Sign) ! add 1 to digit for minus sign
        end if

        if (present(zerofill)) then
            if (zerofill > digit) then
                str_zfill = integer32_to_string_with_format(digit)
                ! format such as '(i10.11)' is not allowed. zero-filling digits are limited to `digit`
            else
                str_zfill = integer32_to_string_with_format(zerofill)
            end if
            str_zfill = "."//str_zfill
        else
            str_zfill = ""
        end if

        fmt = "(I"//str_digits//str_zfill//")"

        str = to_string(i32, fmt)
    end function integer32_to_string_with_digits

    !------------------------------------------------------------------!
    !| Returns `.true.` if the 1-byte integer is positive, including 0.
    pure logical function is_positive_int8(i8)
        implicit none
        !&<
        integer(int8), intent(in)    :: i8
            !! 1-byte integer
        !&>

        if (i8 >= 0) then
            is_positive_int8 = .true.
        else
            is_positive_int8 = .false.
        end if
    end function is_positive_int8

    !| Returns `.true.` if the 2-byte integer is positive, including 0.
    pure logical function is_positive_int16(i16)
        implicit none
        !&<
        integer(int16), intent(in)    :: i16
            !! 2-byte integer
        !&>

        if (i16 >= 0) then
            is_positive_int16 = .true.
        else
            is_positive_int16 = .false.
        end if
    end function is_positive_int16

    !| Returns `.true.` if the 4-byte integer is positive, including 0.
    pure logical function is_positive_int32(i32)
        implicit none
        !&<
        integer(int32), intent(in)    :: i32
            !! 4-byte integer
        !&>

        if (i32 >= 0) then
            is_positive_int32 = .true.
        else
            is_positive_int32 = .false.
        end if
    end function is_positive_int32

    !| Returns `.true.` if the 8-byte integer is positive, including 0.
    pure logical function is_positive_int64(i64)
        implicit none
        !&<
        integer(int64), intent(in)    :: i64
            !! 8-byte integer
        !&>

        if (i64 >= 0) then
            is_positive_int64 = .true.
        else
            is_positive_int64 = .false.
        end if
    end function is_positive_int64

    !------------------------------------------------------------------!
    !| Returns `.true.` if the 1-byte integer is negative, not including 0.
    pure logical function is_negative_int8(i8)
        implicit none
        !&<
        integer(int8), intent(in)    :: i8
            !! 1-byte integer
        !&>

        is_negative_int8 = .not. is_positive(i8)
    end function is_negative_int8

    !| Returns `.true.` if the 2-byte integer is negative, not including 0.
    pure logical function is_negative_int16(i16)
        implicit none
        !&<
        integer(int16), intent(in)    :: i16
            !! 2-byte integer
        !&>

        is_negative_int16 = .not. is_positive(i16)
    end function is_negative_int16

    !| Returns `.true.` if the 4-byte integer is negative, not including 0.
    pure logical function is_negative_int32(i32)
        implicit none
        !&<
        integer(int32), intent(in)    :: i32
            !! 4-byte integer
        !&>

        is_negative_int32 = .not. is_positive(i32)
    end function is_negative_int32

    !| Returns `.true.` if the 8-byte integer is negative, not including 0.
    pure logical function is_negative_int64(i64)
        implicit none
        !&<
        integer(int64), intent(in)    :: i64
            !! 8-byte integer
        !&>

        is_negative_int64 = .not. is_positive(i64)
    end function is_negative_int64
end module numeric_integer


subroutine take_forward_euler_step(t, dt, q)

! Take a time step using Forward Euler.
!
! Args:
!   t: Time before the step.
!   dt: Length of time step.
!   q: PDE solution at time t.

    !$ use omp_lib
    implicit none

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

    double precision, intent(in) :: t, dt
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(inout) :: q

    double precision, dimension(1-mbc:mx+mbc, meqn) :: op_output
    integer :: ix, ieqn

    call apply_bcs(t, q)
    call apply_pde_operator(t, q, op_output)

    do ieqn = 1, meqn
        !$omp parallel do
        do ix = 1, mx
            q(ix, ieqn) = q(ix, ieqn) + dt * op_output(ix, ieqn)
        end do
    end do

end subroutine take_forward_euler_step


!! R468 array-constructor
!    is (/ ac-spec /)
!    or lbracket ac-spec rbracket
!
! NOTE 4.68
!
dimension X(3), Y(3,2)
X = (/ 3.2, 4.01, 6.5 /)
Y = RESHAPE (SOURCE = [ 2.0, [4.5, 4.5 ], X ], SHAPE = [ 3, 2 ])
end


module utils
  contains
	subroutine PRINT_MATRIX( DESC, M, N, A, LDA )
	  CHARACTER*(*)    DESC
	  INTEGER          M, N, LDA
	  INTEGER          M1, N1
	  COMPLEX          A( LDA, * )

	  INTEGER          I, J

	  WRITE(*,*)
	  WRITE(*,*) DESC
	  M1 = M
	  N1 = N
	  if (M1>5) M1 = 5
	  if (N1>5) N1 = 5
	  DO I = 1, M1
		 WRITE(*,9998) ( A( I, J ), J = 1, N1 )
	  END DO

9998 FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )
	end

end module utils

program solve
	use utils
!     .. Parameters ..
	INTEGER          N, NRHS
	PARAMETER        ( NRHS = 1 )
	INTEGER          LDA, LDB

!     .. Local Scalars ..
	INTEGER          INFO

!     .. Local Arrays ..
	INTEGER, dimension (:), allocatable ::   IPIV
!		  COMPLEX          A( LDA, N ), B( LDB, NRHS )
	complex, dimension (:,:), allocatable :: A
	complex, dimension (:), allocatable :: R
	complex, dimension (:,:), allocatable :: B

	!real(8), dimension (:,:), allocatable :: A
	!real(8), dimension (:), allocatable :: R
	!real(8), dimension(LDB,N) :: B

	integer, dimension( 4 )  ::	ISEED

	INTEGER :: c1,c2,cr,cm, i
     real    ::  T1,T2 ,rate
     real    ::  dt1, dt2, dt3
	 real sys_clock
     real, dimension(2) :: tarray
     real :: result

	 CHARACTER(len=32) :: arg
	 integer stat
     print *, 'Solve the complex equations A*X = B.'
	 print *, 'and calc exec time'
	 CALL getarg(1, arg)
	 READ(arg,*,iostat=stat)N
	 if (stat<0) then
		print *, "set default size"
		N = 4
	 end if
	 print *, "N=", N
	 LDA = N
	 LDB = N

	 ISEED = (/ 1, 2, 3, 4 /)

	 CALL system_clock(count_rate=cr)
	 CALL system_clock(count_max=cm)
	 rate = REAL(cr)
!	 WRITE(*,*) "system_clock rate ",rate

	 allocate ( IPIV(N) )
	 allocate ( A(N,N) )
	 allocate ( B(LDB,NRHS) )
	 allocate ( R(N) )

    call cpu_time(T1)
	call clarnv	(1, ISEED, N*N,	A )
	call clarnv	(1, ISEED, N,	R )

	print *, "1"
	do i = 1,N
     B(i,1) = R(i)
	! B(i,2) = R(i)
	end do
	print *, "2"
     call cpu_time(T2)
     dt1 = T2-T1

	 CALL SYSTEM_CLOCK(c1)
	 call cpu_time(T1)

	 CALL PRINT_MATRIX( 'A matrix', N, N, A, LDA )

!   Solve the equations A*X = B.

	CALL CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )

	call cpu_time(T2)
	CALL SYSTEM_CLOCK(c2)
	dt3 = T2-T1
	sys_clock = (c2 - c1)/rate
	print *
	print *, dt3, sys_clock

	IF( INFO.GT.0 ) THEN
		WRITE(*,*)'The diagonal element of the triangular factor of A,'
		WRITE(*,*)'U(',INFO,',',INFO,') is zero, so that'
		WRITE(*,*)'A is singular; the solution could not be computed.'
		STOP
	 END IF

	 CALL PRINT_MATRIX( 'Solution', N, NRHS, B, LDB )

	 !print *, sum(c)
     print *,"end"
end program solve


      SUBROUTINE GRDDL(A,LDA,NA,NF,NE,NS,S,OPT,IND,AS,LDAS,BS,LDBS,IERR)
      IMPLICIT NONE
*
*  -- user defined driver routine --
*
*
*     .. Scalar Arguments ..
      INTEGER            NA, NF, NE, NS, IERR, LDA, LDAS, LDBS
      DOUBLE PRECISION   OPT
*     ..
*     .. Array Arguments ..
      INTEGER            S(*), IND(*)
      DOUBLE PRECISION   A(LDA,*), AS(LDAS,*), BS(LDBS,*)
*     ..
*
*  Purpose
*  =======
*
*  GRDDL computes a Greedy solution for maximum entropy sampling
*  using the dual greedy algorithm described in
*  Ko, Lee, Queyranne (1994), An exact algorithm for maximum entropy
*  sampling, Operations Research 43 (1995), 684-691.
*
*
*  Arguments
*  =========
*
*  A        (input) DOUBLE PRECISION array of DIMENSION (NA,NA).
*           Before entry, the array A must contain matrix of
*           covariances.
*           Unchanged on exit.
*
*  NA       (input) INTEGER.
*           On entry, NA specifies the number of rows/columns of A
*           as declared in the calling (sub) program. NA >= 0.
*           Unchanged on exit.
*
*  NF       (input) INTEGER.
*           On entry, NF specifies how many indices are forced into
*           every feasible solution. 0 <= NS <= NA.
*           The stations related with NF have to be the first one in A.
*           Unchanged on exit.
*
*  NE       (input) INTEGER.
*           On entry, NE specifies how many stations will be treated
*           as eligible for consideration. NE = NA - NF. The matrix A
*           stations related with NE have to be the last one in A.
*           Unchanged on exit.
*
*  NS       (input) INTEGER.
*           On entry, NS specifies how many stations have to be added
*           to the current network. 0 <= NS <= NE.
*           Unchanged on exit.
*
*  S        (output) INTEGER array of DIMENSION (NE).
*           Contains The initial solution computed by the
*           greedy algorithm.
*
*  OPT      (output) DOUBLE PRECISION value.
*           The determinant of the initial solution computed by the
*           greedy algorithm.
*
*  IND      (work array) INTEGER, DIMENSION (NA).
*
*  AS       (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  BS       (work array) DOUBLE PRECISION, DIMENSION (NA,NA).
*
*  IERR     (output) INTEGER
*           the error indicator from DPOFA.  this will be
*           zero unless the matrix being factorized is
*           not positive definite.
*
*
*  =====================================================================
*
*     ..
*     .. Parameters ..
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, K, CARDS, JMIN, JMAX, NI
      DOUBLE PRECISION   DET1, DETMAX
      CHARACTER*1        TRANS
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DET(2)
*     ..
*     .. External Functions ..
*     ..
*     .. External Subroutines ..
      EXTERNAL           SUBDET
*     ..
*     .. Intrinsic Functions ..
*     ..
*     .. Executable Statements ..
*
*
* Initializing

      DETMAX=0.0D0
      DO 10 I=1,NE
         S(I)=I+NF
 10   CONTINUE
      DO 11 I=1,NF
         IND(I)=I
 11   CONTINUE
      DO 12 I=NF+1,NA
         IND(I)=0
 12      CONTINUE
      JMIN=1

* Computation of the cardinality of the actual solution

 20   CONTINUE
      CARDS=NF
      DO 21 I=1,NE
         IF (S(I).NE.0) THEN
            CARDS=CARDS+1
         ENDIF
 21   CONTINUE

* Is the actual solution S feasible?

      IF (CARDS.GT.(NF+NS)) THEN
         GOTO 22
      ELSE
         GOTO 30
      ENDIF
 22   CONTINUE

* Computation of the actual index set IND

      K=NF+1
      DO 221 I=JMIN,NE
         IF (S(I).NE.0 .AND. I.NE.JMIN) THEN
            IND(K)=S(I)
            K=K+1
         ENDIF
 221  CONTINUE

* Computation of the determinant of the covariance matrix
* of the actual infeasible solution

      NI=K-1
      CALL SUBDET(A,LDA,NA,AS,LDAS,IND,NI,BS,LDBS,IERR,DET)
      DETMAX=DET(1)*10.0**DET(2)
      JMAX=JMIN

* Selecting the station J as candidate to reduce the network
* Computation of the determinant of the covariance matrix
* of the resulting network using cholesky factorization

      DO 23 J=JMIN+1,NE
         IF (S(J).NE.0) THEN
            K=NF+1
            DO 222 I=JMIN,NE
               IF (S(I).NE.0 .AND. I.NE.J) THEN
                  IND(K)=S(I)
                  K=K+1
               ENDIF
 222        CONTINUE
            NI=K-1
            CALL SUBDET(A,LDA,NA,AS,LDAS,IND,NI,BS,LDBS,IERR,DET)
            DET1=DET(1)*10.0**DET(2)

* Looking for the maximal determinant
* Storing the index for which the determinant attained its maximum

            IF (DET1.GT.DETMAX) THEN
               DETMAX=DET1
               JMAX=J
            ENDIF
         ENDIF
 23   CONTINUE

* Deleting the station JMAX from the current network

      S(JMAX)=0

* Determining the station with the smallest index in the current network

      IF (JMIN.EQ.JMAX) THEN
         DO 24 J=JMAX+1,NE
            IF (S(J).NE.0) THEN
               GOTO 25
            ENDIF
 24      CONTINUE
 25      JMIN=J
      ENDIF

      GOTO 20

 30   CONTINUE

      OPT=DETMAX
      DO 31 I=1,NS
 31   CONTINUE
      RETURN
      END


      SUBROUTINE MPYA3D (AA,BB,NROW,BAND,CC)
C
C     WITH ENTRY MPYA3S (A,B,NROW,BAND,C)
C
C     WAS NAMED DATBAD/DATBAS IN UAI CODE
C
C     THESE ROUTINES PERFORM TRIPLE MATRIX MULTIPLY OF THE FORM
C
C                          T
C                 C = C + A * B * A
C
C     ON TWO INCOMING ROW-LOADED MATRICES A AND B, AND ADD THEM TO
C     MATRIX C
C
C     THE INCOMING MATRICES MUST BE SQUARE (AND OBVIOUSLY OF THE SAME
C     SIZE, NROW.) AND
C     SYMMETRICAL (SINCE WE OPERATE ONLY ON LOWER TRIANGULAR MATRICES)
C
C     MATRIX A CAN BE A PSUEDO-DIAGONAL MATRIX, I.E. A MATRIX HAVING
C     SQUARE PARTITIONS OF NON-ZERO TERMS ALONG ITS DIAGONAL.
C     THESE PARTITIONS ARE OF THE SIZE  BAND X BAND.
C     NOTE THAT NROW MUST BE AN INTEGER MULTIPLE OF BAND.
C
C     THIS ALGORITHM IS SUITABLE FOR TRIPLE MULTIPLIES INVOLVING GLOBAL
C     TRANSFORMATIONS.
C
C
      INTEGER          BAND
      REAL             A(1) ,B(1) ,C(1)
      DOUBLE PRECISION AA(1),BB(1),CC(1),DD
C
C
C     DOUBLE PRECISION VERSION
C
      II = 0
      DO 50 IB = 1,NROW
      IA1 = ((IB-1)/BAND+1)*BAND
C
      DO 40 ID1 = 1,NROW,BAND
      ID2 = ID1 + BAND - 1
      IF (ID1 .GT. IA1) GO TO 50
C
      ID11N = (ID1-1)*NROW
      DO 30 ID = ID1,ID2
      JJ = ID11N
      DD = 0.0D0
C
      DO 10 IC = ID1,ID2
      IBIC = II + IC
      ICID = JJ + ID
      IF (AA(ICID) .EQ. 0.0D0) GO TO 10
      DD = DD + BB(IBIC)*AA(ICID)
   10 JJ = JJ + NROW
C
      IF (DD .EQ. 0.0D0) GO TO 30
      KK = (ID-1)*NROW
C
      DO 20 IA = ID,IA1
      IBIA = II + IA
      IF (AA(IBIA) .EQ. 0.0D0) GO TO 20
      IAID = KK + ID
      CC(IAID) = CC(IAID) + DD*AA(IBIA)
   20 KK = KK + NROW
C
   30 CONTINUE
   40 CONTINUE
   50 II = II + NROW
C
C     COPY THE LOWER TRIANGLE TO THE UPPER
C
      KK = NROW - 1
      II = 0
      DO 70 I = 1,KK
      IB = I + 1
      JJ = I*NROW
      DO 60 J = IB,NROW
      CC(II+J) = CC(JJ+I)
   60 JJ = JJ + NROW
   70 II = II + NROW
C
      RETURN
C
C
      ENTRY MPYA3S (A,B,NROW,BAND,C)
C     ==============================
C
C     SINGLE PRECISION VERSION
C
      II = 0
      DO 150 IB = 1,NROW
      IA1 = ((IB-1)/BAND+1)*BAND
C
      DO 140 ID1 = 1,NROW,BAND
      ID2 = ID1 + BAND - 1
      IF (ID1 .GT. IA1) GO TO 150
C
      ID11N = (ID1-1)*NROW
      DO 130 ID = ID1,ID2
      JJ = ID11N
      DD = 0.0D0
C
      DO 110 IC = ID1,ID2
      IBIC = II + IC
      ICID = JJ + ID
      IF (A(ICID) .EQ. 0.0) GO TO 110
      DD = DD + DBLE(B(IBIC))*DBLE(A(ICID))
  110 JJ = JJ + NROW
      IF (DD .EQ. 0.0D0) GO TO 130
      KK = (ID-1)*NROW
C
      DO 120 IA = ID,IA1
      IBIA = II + IA
      IF (A(IBIA) .EQ. 0.0) GO TO 120
      IAID = KK + ID
      C(IAID) = SNGL(DBLE(C(IAID)) + DD*DBLE(A(IBIA)))
  120 KK = KK + NROW
C
  130 CONTINUE
  140 CONTINUE
  150 II = II + NROW
C
C     COPY THE LOWER TRIANGLE TO THE UPPER
C
      KK = NROW - 1
      II = 0
      DO 170 I = 1,KK
      IB = I + 1
      JJ = I*NROW
      DO 160 J = IB,NROW
      C(II+J) = C(JJ+I)
  160 JJ = JJ + NROW
  170 II = II + NROW
C
      RETURN
      END


!=====================================================================!
! Main Program for testing the integrators on different test problems
!=====================================================================!

#include "scalar.fpp"

program test_time_integration

  use vanderpol_system          , only : fvanderpol => vanderpol_first_order
  use spring_dynamics_class     , only : smd
  use freefall_dynamics_class   , only : freefall
  use test_ode_class            , only : ODE
  use first_order_ode_class     , only : FODE
  use dynamic_physics_interface , only : dynamics

  implicit none

  class(dynamics), allocatable :: sys

  test_vanderpol: block
    !allocate(sys, source = smd(0.5d0, 6.0d0, 18.0d0))
    allocate(sys, source = FODE(9.8d0, -0.196d0))
    !allocate(sys, source = fvanderpol(1.0d0))
    !allocate(sys, source = freefall(1.0d0, -10.0d0))
    !allocate(sys, source = ODE(A=[2.0d0, 2.0d0, 2.0d0], order=4, nvars=3))
    call test_integrators(sys, 0.0d0, 10.0d0, 1250, "-1250")
    call test_integrators(sys, 0.0d0, 10.0d0, 2500, "-2500")
    call test_integrators(sys, 0.0d0, 10.0d0, 5000, "-5000")
    call test_integrators(sys, 0.0d0, 10.0d0, 10000, "-10000")
    deallocate(sys)
  end block test_vanderpol

contains

  subroutine test_integrators(test_system, tinit, tfinal, nsteps, suffix)

    use abm_integrator_class , only : ABM
    use newmark_integrator_class , only : newmark
    use runge_kutta_integrator_class , only : dirk
    use backward_differences_integrator_class , only : bdf

    class(dynamics), intent(inout) :: test_system
    type(scalar)  :: tinit, tfinal
    type(integer) :: nsteps
    type(ABM)     :: abmobj
    type(newmark) :: nbg
    type(dirk)    :: dirkobj
    type(bdf)     :: bdfobj
    type(scalar)  :: h
    character(len=*) :: suffix

    h = (tfinal-tinit)/dble(nsteps)

    ! Dirk
    dirkobj = DIRK(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=2)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution("smd-dirk2"//suffix//".dat")

    dirkobj = DIRK(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=3)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution("smd-dirk3"//suffix//".dat")

    dirkobj = DIRK(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=4)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution("smd-dirk4"//suffix//".dat")

    ! bdf
    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=1)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf1"//suffix//".dat")

    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=2)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf2"//suffix//".dat")

    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=3)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf3"//suffix//".dat")

    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=4)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf4"//suffix//".dat")

    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=5)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf5"//suffix//".dat")

    bdfobj = BDF(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=6)
    call bdfobj % to_string()
    call bdfobj % solve()
    call bdfobj % write_solution("smd-bdf6"//suffix//".dat")

    ! abm
    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=1)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm1"//suffix//".dat")

    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=2)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm2"//suffix//".dat")

    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=3)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm3"//suffix//".dat")

    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=4)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm4"//suffix//".dat")

    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=5)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm5"//suffix//".dat")

    abmobj = ABM(system = test_system, tinit=tinit, tfinal = tfinal, &
         & h=h, implicit=.true., accuracy_order=6)
    call abmobj % to_string()
    call abmobj % solve()
    call abmobj % write_solution("smd-abm6"//suffix//".dat")

  end subroutine test_integrators

end program test_time_integration


MODULE InternalCoords

  IMPLICIT NONE

  CONTAINS

    PURE REAL(8) FUNCTION distance(x,y)

      IMPLICIT NONE
      REAL(4), INTENT(IN) :: x(3), y(3)
      INTEGER :: i
      REAL(8) :: sum, diff

      sum = 0.0d0
      DO i = 1, 3
        diff = x(i) - y(i)
        sum = sum + (diff*diff)
      ENDDO

      distance = SQRT(sum)

    END FUNCTION distance

!*

!  PURE REAL(8) FUNCTION angle(x,y,z)

!    IMPLICIT NONE
!    REAL(4), INTENT(IN) :: x(3), y(3), z(3)
!    REAL(4) :: diff(3))

!    angle = 0.0d0

!  END FUNCTION angle

!*

!  PURE REAL(8) FUNCTION dot_product(a,b)

!    IMPLICIT NONE
!    REAL(8), INTENT(IN) :: a(:), b(:)

!    dot_product = SUM(a(:)*b(:))

!  END FUNCTION

END MODULE InternalCoords


c
c  This is a function used when IMSL is not available
c
c
c***********************************************
c
      logical function invert4(R,S)
c
c***********************************************
c
c    calculates the inverse matrix of the 4x4 real matrix R
c
c    11/6/95 by J. Dwyer
c
      real R(4,4)    ! input matrix
      real  S(4,4)    ! inverse matrix of R
      real Q(3,3)     ! submatrix
      real  detR, det3      ! determinant of R and Q
      integer  indexk, indexl
c
      detR = 0.0
      i = 1
      do 30 j=1,4
          indexk = 1
          do 20 k=1,4
              indexl = 1
              do 10 l=1,4
                  if ((k.ne.i).and.(l.ne.j)) then
                       Q(indexk,indexl)=R(k,l)
                  end if
                 if (l.ne.j) indexl = indexl+1
10    continue
              if (k.ne.i) indexk = indexk+1
20    continue
           detR = detR+((-1.0)**(i+j))*R(i,j)*det3(Q)
30    continue

c
      if (detR.ne.0.0) then
         invert4 = .true.
         do 100 i=1,4
            do 100 j=1,4
               indexk = 1
               do 60 k=1,4
                  indexl = 1
                   do 50 l=1,4
                       if ((k.ne.i).and.(l.ne.j)) then
                           Q(indexk,indexl)=R(k,l)
                       end if
                       if (l.ne.j) indexl = indexl+1
50               continue
                   if (k.ne.i) indexk = indexk+1
60           continue
               S(i,j) = ((-1.0)**(i+j))*det3(Q)/detR
100       continue
c
c        call check_inverse(R,S)
c
         return  ! successful
      end if
c
      invert4 = .false.  ! no inverse possible
      return
      end  ! end invert4
c
c
c
c
c************************************************
c
      real function det3(Q)
c
c************************************************
c
c  calculates the determinent of the 3x3 real matrix Q
c
      real  Q(3,3)
c
      det3 = Q(1,1)*(Q(2,2)*Q(3,3)-Q(3,2)*Q(2,3))-
     1          Q(2,1)*(Q(1,2)*Q(3,3)-Q(1,3)*Q(3,2))+
     1          Q(3,1)*(Q(1,2)*Q(2,3)-Q(1,3)*Q(2,2))
c
      return
      end  ! end det3
c
c
c
c
c***********************************************
c
      subroutine check_inverse(R,S)
c
c***********************************************
c
c    calculates the inverse matrix of the 4x4 real matrix R
c
c    11/6/95 by J. Dwyer
c         fixed U(4,4)  5/1/96
c
      real  R(4,4)    ! input matrix
      real  S(4,4)    ! inverse matrix of R
      real  U(4,4)

      do 100 i=1,4
         do 100 j=1,4
             U(i,j) = 0.0
100     continue
c
      do 300 i=1,4
         do 300 j=1,4
             do 200 k=1,4
                 U(i,j) = U(i,j)+R(i,k)*S(k,j)
200     continue
300     continue
c
      print *, ' '
      do 500 i=1,4
            print *, U(i,1), U(i,2), U(i,3), U(i,4)
500     continue
c
      return
      end  ! check_inverse
c

EPACE_STEP_code/2_sdf_rom_spikes/sdf_rom_spikes_source/files in vax dir but not used/INVERT.f95