!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     This file contains code and documentation for subroutines
!     shpei and shpe.
!
submodule(scalar_projection_routines) scalar_projection_regular_grid

contains

    ! Purpose:
    !
    !     the n**2 projection with complement, odd/even
    !     factorization and zero truncation on an
    !     equally spaced grid as defined in the JCP paper
    !     "Generalized discrete spherical harmonic transforms"
    !     by Paul N. Swarztrauber and William F. Spotz
    !     It is equivalent to a harmonic analysis followed
    !     by a synthesis except faster and requires less memory.
    !
    !     subroutine shpe(nlat, nlon, isym, mtrunc, x, y, idxy, &
    !     wshp, lwshp, iwshp, liwshp, work, lwork, ierror)
    !
    !     shpe projects the array x onto the set of functions represented
    !     by a discrete set of spherical harmonics.
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3.
    !
    !     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 or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !            nlon must beat least 4.
    !
    !     isym   currently not used.
    !
    !     mtrunc the highest longitudinal wave number retained in the
    !            projection. It must be less than or equal to
    !            the minimum of nlat-1 and nlon/2. The first wave
    !            number is zero. For example, if wave numbers 0 and
    !            1 are desired then mtrunc = 1.

    !            zero.
    !
    !     x      a two dimensional array that contains the the nlat
    !            by nlon array x(i, j) defined at the colatitude point
    !            theta(i) = (i-1)*pi/(nlat-1) and longitude point phi(j) =
    !            (j-1)*2*pi/nlon.
    !
    !     idxy   the first dimension of the arrays x and y as they
    !            appear in the program that calls shpe. It must be
    !            at least nlat.
    !
    !     wshp   a single precision array that must be saved for
    !            repeated use by subroutine shpe.
    !
    !     lwshp  the dimension of the array wshp as it appears in the
    !            program that calls shpei. It must be at least
    !            2*(nlat + 1)**2+nlon+log2(nlon)
    !
    !     iwshp  an integer array that must be saved for repeated
    !            use by subroutine shpe.
    !
    !
    !     liwshp the dimension of the array iwshp as it appears in the
    !            program that calls shpei. It must be at least
    !            4*(nlat + 1).
    !
    !     work   a single precision work array that does
    !            not have to be saved.
    !
    !     lwork  the dimension of the array work as it appears in the
    !            program that calls shpe. It must be at least
    !            max(nlat*nlon, 4*(nlat + 1)).
    !
    !     **************************************************************
    !
    !     output parameters
    !
    !     y      an nlat by nlon single precision array that contains
    !            the projection of x onto the set of functions that
    !            can be represented by the discrete set of spherical
    !            harmonics. The arrays x(i, j) and y(i, j) are located
    !            at colatitude point theta(i) = (i-1)*pi/(nlat-1) and
    !            longitude point phi(j) = (j-1)*2*pi/nlon.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of mtrunc
    !            = 5  error in the specification of lwshp
    !            = 6  error in the specification of liwshp
    !            = 7  error in the specification of lwork
    !
    module subroutine shpe(nlat, nlon, isym, mtrunc, x, y, idxy, &
        wshp, lwshp, iwshp, liwshp, work, lwork, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: mtrunc
        real(wp),    intent(in)  :: x(idxy, nlon)
        real(wp),    intent(out) :: y(idxy, nlon)
        integer(ip), intent(in)  :: idxy
        real(wp),    intent(in)  :: wshp(lwshp)
        integer(ip), intent(in)  :: lwshp
        integer(ip), intent(in)  :: iwshp(liwshp)
        integer(ip), intent(in)  :: liwshp
        real(wp),    intent(out) :: work(lwork)
        integer(ip), intent(in)  :: lwork
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: iw1
        integer(ip) :: iw2
        integer(ip) :: iw3
        integer(ip) :: iw4
        integer(ip) :: jw1
        integer(ip) :: jw2
        integer(ip) :: jw3
        integer(ip) :: jw4
        integer(ip) :: log2n
        integer(ip) :: lw1
        integer(ip) :: mmax
        integer(ip) :: mwrk
        integer(ip) :: nloc1
        integer(ip) :: nloc2
        integer(ip) :: nte
        type(SpherepackUtility) :: util

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        mmax = min(nlat-1, nlon/2)
        if (mtrunc < 0 .or. mtrunc > mmax) return
        ierror = 5
        log2n = int(log(real(nlon, kind=wp))/log(TWO), kind=ip)
        lw1 = 2*(nlat + 1)**2
        if (lwshp<lw1+nlon+log2n) return
        ierror = 6
        if (liwshp<4*(nlat + 1)) return
        ierror = 7
        mwrk = max(nlat*nlon, 4*(nlat + 1))
        if (lwork <mwrk) return
        ierror = 0

        y(1:nlat, :) = x(1:nlat, :)

        call util%hfft%forward(nlat, nlon, y, idxy, wshp(lw1+1))

        ! Set workspace index pointers
        nte = (nlat + 1)/2
        nloc1 = 2*nte*nte
        nloc2 = nlat+1
        lw1 = 2*(nlat + 1)**2
        iw1 = 1
        iw2 = iw1+nloc1
        iw3 = iw2+nloc1
        iw4 = iw3+nloc1
        jw1 = 1
        jw2 = jw1+nloc2
        jw3 = jw2+nloc2
        jw4 = jw3+nloc2

        call shpe_lower_utility_routine(nlat, nlon, isym, mtrunc, y, y, idxy, ierror, &
            nte, wshp(iw1), wshp(iw2), wshp(iw3), wshp(iw4), iwshp(jw1), &
            iwshp(jw2), iwshp(jw3), iwshp(jw4), work(jw1), &
            work(jw2), work(jw3), work(jw4))

        call util%hfft%backward(nlat, nlon, y, idxy, wshp(lw1+1))

        y(1:nlat, :) = y(1:nlat, :)/nlon

    end subroutine shpe

    ! Purpose:
    !
    !     Initializes arrays wshp and iwshp for
    !     subsequent repeated use by subroutine shpe, which
    !     performs the harmonic projection equivalent to a
    !     harmonic analysis followed by harmonic synthesis
    !     but faster and with less memory.
    !
    !     subroutine shpei(nlat, nlon, isym, mtrunc, wshp, lwshp, iwshp,
    !     liwshp, work, lwork, ierror)
    !
    !     shpei initializes arrays wshp and iwshp for repeated use
    !     by subroutine shpe ....
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3.
    !
    !     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 or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !            nlon must beat least 4.
    !
    !     isym   currently not used.
    !
    !     mtrunc the highest longitudinal wave number retained in the
    !            projection. It must be less than or equal to
    !            the minimum of nlat-1 and nlon/2. The first wave
    !            number is zero. For example, if wave numbers 0 and
    !            1 are desired then mtrunc = 1.
    !
    !     lwshp  the dimension of the array wshp as it appears in the
    !            program that calls shpei. It must be at least
    !            2*(nlat + 1)**2+nlon+log2(nlon)
    !
    !     liwshp the dimension of the array iwshp as it appears in the
    !            program that calls shpei. It must be at least
    !            4*(nlat + 1).
    !
    !     lwork  the dimension of the array work as it appears in the
    !            program that calls shpei. It must be at least
    !            1.25*(nlat + 1)**2+7*nlat+8.
    !
    !     **************************************************************
    !
    !     output parameters
    !
    !     wshp   a single precision array that must be saved for
    !            repeated use by subroutine shpe.
    !
    !     iwshp  an integer array that must be saved for repeated
    !            use by subroutine shpe.
    !
    !     work   a real work array that does
    !            not have to be saved.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of mtrunc
    !            = 5  error in the specification of lwshp
    !            = 6  error in the specification of liwshp
    !            = 7  error in the specification of lwork
    !
    module subroutine shpei(nlat, nlon, isym, mtrunc, wshp, lwshp, iwshp, &
        liwshp, work, lwork, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: mtrunc
        real(wp),    intent(out) :: wshp(lwshp)
        integer(ip), intent(in)  :: lwshp
        integer(ip), intent(in)  :: iwshp(liwshp)
        integer(ip), intent(in)  :: liwshp
        real(wp),    intent(out) :: work(lwork)
        integer(ip), intent(in)  :: lwork
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: iw1
        integer(ip) :: iw2
        integer(ip) :: iw3
        integer(ip) :: iw4
        integer(ip) :: jw1
        integer(ip) :: jw2
        integer(ip) :: jw3
        integer(ip) :: jw4
        integer(ip) :: kw1
        integer(ip) :: kw10
        integer(ip) :: kw11
        integer(ip) :: kw12
        integer(ip) :: kw13
        integer(ip) :: kw2
        integer(ip) :: kw3
        integer(ip) :: kw4
        integer(ip) :: kw5
        integer(ip) :: kw6
        integer(ip) :: kw7
        integer(ip) :: kw8
        integer(ip) :: kw9
        integer(ip) :: log2n
        integer(ip) :: lw1
        integer(ip) :: mlwk
        integer(ip) :: mmax
        integer(ip) :: nloc1
        integer(ip) :: nloc2
        integer(ip) :: nte
        type(SpherepackUtility) :: util

        ! Set contants
        mmax = min(nlat-1, nlon/2)
        lw1 = 2*(nlat + 1)**2
        log2n = int(log(real(nlon, kind=wp))/log(TWO), kind=ip)
        mlwk = 5*((nlat + 1)**2 + 7*nlat + 8)/4

        ! Check calling arguments
        if (nlat < 3) then
            ierror = 1
        else if (nlon < 4) then
            ierror = 2
        else if (isym < 0 .or. isym > 2) then
            ierror = 3
        else if (mtrunc < 0 .or. mtrunc > mmax) then
            ierror = 4
        else if (lwshp < lw1+nlon+log2n) then
            ierror = 5
        else if (liwshp < 4*(nlat + 1)) then
            ierror = 6
        else if (lwork < mlwk) then
            ierror = 7
        else
            ierror = 0
        end if

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

        call util%hfft%initialize(nlon, wshp(lw1+1))

        ! Set workspace index pointers
        nte = (nlat + 1)/2
        nloc1 = 2*nte*nte
        nloc2 = nlat+1
        lw1 = 2*(nlat + 1)**2
        iw1 = 1
        iw2 = iw1+nloc1
        iw3 = iw2+nloc1
        iw4 = iw3+nloc1
        jw1 = 1
        jw2 = jw1+nloc2
        jw3 = jw2+nloc2
        jw4 = jw3+nloc2
        kw1 = 1
        kw2 = kw1+nte
        kw3 = kw2+nte
        kw4 = kw3+nte
        kw5 = kw4+nte+1
        kw6 = kw5+nte
        kw7 = kw6+nte
        kw8 = kw7+nte
        kw9 = kw8+nte
        kw10 = kw9+nloc2+nloc2
        kw11 = kw10+nloc2
        kw12 = kw11+nloc1
        kw13 = kw12+nloc1

        call shpei_lower_utility_routine(nlat, nlon, isym, mtrunc, nte, ierror, wshp(iw1), wshp(iw2), &
            wshp(iw3), wshp(iw4), iwshp(jw1), iwshp(jw2), iwshp(jw3), &
            iwshp(jw4), work(kw1), work(kw2), work(kw3), work(kw4), work(kw5), &
            work(kw6), work(kw7), work(kw8), work(kw9), work(kw10), work(kw11), &
            work(kw12), work(kw11), work(kw12), work(kw13))

    end subroutine shpei

    subroutine shpei_lower_utility_routine(nlat, nlon, isym, mtrunc, idp, ierror, &
        pe, po, ze, zo, ipse, jzse, ipso, jzso, &
        cp, work, wx, s, e, thet, xx, z, a, b, we, ped, wo, pod, u)

        real(wp) :: dfn
        integer(ip) :: i
        integer(ip) :: idp
        integer(ip) :: ierror
        integer(ip) :: info
        integer(ip) :: iip
        integer(ip) :: ipse
        integer(ip) :: ipso
        integer(ip) :: isym
        integer(ip) :: it
        integer(ip) :: j
        integer(ip) :: js
        integer(ip) :: jzse
        integer(ip) :: jzso
        integer(ip) :: k
        integer(ip) :: lock
        integer(ip) :: m
        integer(ip) :: modn
        integer(ip) :: mp1
        integer(ip) :: mrank
        integer(ip) :: ms2
        integer(ip) :: mtrunc
        integer(ip) :: mxtr
        integer(ip) :: n
        integer(ip) :: nem
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nom
        integer(ip) :: nrank
        integer(ip) :: ns2
        integer(ip) :: nshe
        integer(ip) :: nsho
        integer(ip) :: nte
        integer(ip) :: nto
        real(wp) :: pe
        real(wp) :: po
        real(wp) :: toe
        real(wp) :: tusl
        real(wp) :: ze
        real(wp) :: zo
        real(wp) :: summation, dtheta, v(1, 1), a1, b1, c1
        real(wp) :: cp(idp), work(idp), wx(idp), s(idp+1), &
            e(idp), thet(idp), xx(idp), z(idp), u(idp, idp), &
            we(idp, idp, 2), ped(idp, idp, 2), a(4*idp), b(2*idp), &
            wo(idp, idp, 2), pod(idp, idp, 2)

        dimension pe(idp, idp, 2), po(idp, idp, 2), ze(idp, idp, 2), &
            zo(idp, idp, 2), &
            ipse(idp, 2), jzse(idp, 2), ipso(idp, 2), jzso(idp, 2), &
            nshe(2), nsho(2)

        type(SpherepackUtility) :: util

        ns2 = nlat/2
        modn = nlat-ns2-ns2
        nte = (nlat + 1)/2
        nto = nlat-nte
        tusl = ZERO
        toe = ZERO

        ! Compute grid distribution
        dtheta = pi/(nlat-1)
        do i=1, nte
            thet(i) = real(i-1, kind=wp)*dtheta
        end do

        ! Compute weight matrices for even functions
        do mp1=1, 2
            m = mp1-1
            mrank = nlat-m-m
            nem = (mrank+1)/2
            do j=1, nem
                n = 2*j+m-2
                call util%compute_fourier_coefficients(m, n, cp)
                do i=1, nte
                    call util%compute_legendre_polys_from_fourier_coeff(m, n, thet(i), cp, ped(i, j, mp1))
                end do
                if (m>0) ped(1, j, mp1) = ZERO
            end do

            call singular_value_decomposition(ped(m+1, 1, mp1), idp, nem, nem, s, e, u, &
                idp, v(1, 1), idp, work, 10, info)

            do j=1, nem
                s(j) = ONE/(s(j)**2)
            end do

            ! Compute weight matrix as u  s sup -2 u transpose
            do j=1, nte
                do i=1, nte
                    we(i, j, mp1) = ZERO
                end do
            end do
            do i=1, nem
                do j=1, nem
                    summation = ZERO
                    do k=1, nem
                        summation = summation+s(k)*u(i, k)*u(j, k)
                    end do
                    we(i+m, j+m, mp1) = summation
                end do
            end do
        end do

        we(1, 1, 2) = ONE

        ! Compute n**2 basis (even functions)
        do n=1, nlat+nlat-2
            dfn = n
            a(n) = sqrt(dfn*(dfn+ONE))
        end do
        do n=1, nlat-1
            dfn = n
            b(n) = sqrt((dfn+dfn+3.0)/(dfn+dfn-ONE))
        end do
        !
        mxtr = min(nlat-1, nlon/2, mtrunc)
        iip = 2
        do mp1=1, mxtr+1
            m = mp1-1
            iip = 3-iip
            ms2 = mp1/2
            nrank = ms2+ms2
            mrank = nlat-nrank
            nem = (mrank+1)/2

            ! Compute associated legendre functions
            if (m <= 1) then
                do j=1, nem
                    n = 2*j+m-2
                    call util%compute_fourier_coefficients(m, n, cp)
                    do i=1, nte
                        call util%compute_legendre_polys_from_fourier_coeff(m, n, thet(i), cp, ped(i, j+ms2, iip))
                    end do
                    if (m > 0) ped(1, j+ms2, iip) = ZERO
                end do
            else
                do j=1, nem
                    n = 2*j+m-2
                    if (m > 1 .and. n > mxtr) then
                        do i=1, nte
                            u(i, j+ms2) = ped(i, j+ms2, iip)
                        end do
                    else
                        a1 = b(n-1)*a(n+m-3)/a(n+m-1)
                        b1 = a(n-m+1)/a(n+m-1)
                        if (n-m <= 1) then
                            do i=1, nte
                                u(i, j+ms2) = a1*ped(i, j+ms2-1, iip) &
                                    - b1*ped(i, j+ms2, iip)
                            end do
                        else
                            c1 = b(n-1)*a(n-m-1)/a(n+m-1)
                            do i=1, nte
                                u(i, j+ms2) = a1*ped(i, j+ms2-1, iip) &
                                    - b1*ped(i, j+ms2, iip) + c1*u(i, j+ms2-1)
                            end do
                        end if
                    end if
                end do
                do j=1, nem
                    do i=1, nte
                        ped(i, j+ms2, iip) = u(i, j+ms2)
                    end do
                end do
            end if

            if (.not.(ms2 <= 0. .or. nte <= ms2)) then

                ! initialize array with random numbers
                call random_seed()
                call random_number(xx(1:nte))
                it = 0
                even_iteration: do
                    do i=1, nte
                        z(i) = ZERO
                        wx(i) = ZERO
                        do j=1, nte
                            wx(i) = wx(i)+we(i, j, iip)*xx(j)
                        end do
                    end do

                    do j=1, nte
                        if (j == ms2) cycle
                        call accumulate_inner_products(nte, wx, ped(1, j, iip), z)
                    end do

                    do i=1, nte
                        xx(i) = xx(i)-z(i)
                    end do

                    call compute_normal_regular_grid(nte, xx, idp, we(1, 1, iip))

                    it = it+1
                    if (it > 2) exit even_iteration
                end do even_iteration
                do i=1, nte
                    ped(i, ms2, iip) = xx(i)
                end do
            end if
        end do

        ! Reorder if mtrunc is less than nlat-1
        ! case of even functions
        if (modn == 0) then
            nshe(1) = (nlat-mtrunc-1)/2
            nshe(2) = (nlat-mtrunc-2)/2
        else
            nshe(1) = (nlat-mtrunc)/2
            nshe(2) = (nlat-mtrunc-1)/2
        end if

        do mp1=1, 2
            do j=1, nte
                js = j+nshe(mp1)
                if (js>nte) js = js-nte
                do i=1, nte
                    u(i, js) = ped(i, j, mp1)
                end do
            end do
            do j=1, nte
                do i=1, nte
                    ped(i, j, mp1) = u(i, j)
                end do
            end do
        end do

        call truncate(0, nte, idp, ped(1, 1, 1), nte, ipse(1, 1))
        call truncate(0, nte, idp, ped(1, 1, 2), nte, ipse(1, 2))

        ! Compute the analysis matrices
        do iip=1, 2
            do i=1, nte
                lock = 0
                do j=1, nte
                    summation = ZERO
                    do k=1, nte
                        summation = summation+ped(k, i, iip)*we(k, j, iip)
                    end do
                    pe(i, j, iip) = ped(i, j, iip)
                    ze(j, i, iip) =  summation
                    if (abs(summation)>MACHINE_EPSILON .and. lock == 0) then
                        lock = 1
                        jzse(i, iip) = j
                    end if
                end do
            end do
        end do

        ! Compute weight matrices for odd functions
        do mp1=1, 2
            m = mp1-1
            mrank = nlat-m-m
            nem = (mrank+1)/2
            nom = mrank-nem
            do j=1, nom
                n = 2*j+m-1
                call util%compute_fourier_coefficients(m, n, cp)
                do i=1, nte
                    call util%compute_legendre_polys_from_fourier_coeff(m, n, thet(i), cp, pod(i, j, mp1))
                end do
                if (modn == 1) pod(nte, j, mp1) = ZERO
            end do
            call singular_value_decomposition(pod(m+1, 1, mp1), idp, nom, nom, s, e, u, &
                idp, v(1, 1), idp, work, 10, info)

            do j=1, nom
                s(j) = ONE/(s(j)**2)
            end do

            ! Compute weight matrix as u  s sup -2 u transpose
            do j=1, nte
                do i=1, nte
                    wo(i, j, mp1) = ZERO
                end do
            end do
            do i=1, nom
                do j=1, nom
                    summation = ZERO
                    do k=1, nom
                        summation = summation+s(k)*u(i, k)*u(j, k)
                    end do
                    wo(i+m, j+m, mp1) = summation
                end do
            end do
        end do

        wo(1, 1, 2) = ONE
        if (modn == 1) then
            wo(nte, nte, 1) = ONE
            wo(nte, nte, 2) = ONE
        end if

        ! Compute n**2 basis (odd functions)
        iip = 2
        do mp1=1, mxtr+1
            iip = 3-iip
            m = mp1-1
            ms2 = mp1/2
            nrank = ms2+ms2
            mrank = nlat-nrank
            nem = (mrank+1)/2
            nom = mrank-nem

            ! Compute associated legendre functions
            if (m <= 1) then
                do j=1, nom
                    n = 2*j+m-1
                    call util%compute_fourier_coefficients(m, n, cp)
                    do i=1, nte
                        call util%compute_legendre_polys_from_fourier_coeff(m, n, thet(i), cp, pod(i, j+ms2, iip))
                    end do
                    if (modn == 1) pod(nte, j+ms2, iip) = ZERO
                    if (m>0) pod(1, j+ms2, iip) = ZERO
                end do
            else
                do j=1, nom
                    n = 2*j+m-1
                    if (m > 1 .and. n > mxtr) then
                        do i=1, nte
                            u(i, j+ms2) = pod(i, j+ms2, iip)
                        end do
                    else
                        a1 = b(n-1)*a(n+m-3)/a(n+m-1)
                        b1 = a(n-m+1)/a(n+m-1)
                        if (n-m <= 1) then
                            do i=1, nte
                                u(i, j+ms2) = a1*pod(i, j+ms2-1, iip) &
                                    - b1*pod(i, j+ms2, iip)
                            end do
                        else
                            c1 = b(n-1)*a(n-m-1)/a(n+m-1)
                            do i=1, nte
                                u(i, j+ms2) = a1*pod(i, j+ms2-1, iip) &
                                    - b1*pod(i, j+ms2, iip) + c1*u(i, j+ms2-1)
                            end do
                        end if
                    end if
                    if (modn == 1) u(nte, j+ms2) = ZERO
                end do
                do j=1, nom
                    do i=1, nte
                        pod(i, j+ms2, iip) = u(i, j+ms2)
                    end do
                end do
            end if

            if (.not.(ms2 <= 0. .or. nto <= ms2)) then

                ! initialize array with random numbers
                call random_number(xx(1:nte))

                if (modn == 1) xx(nte) = ZERO

                it = 0
                odd_iteration: do
                    do i=1, nte
                        z(i) = ZERO
                        wx(i) = ZERO
                        do j=1, nto
                            wx(i) = wx(i)+wo(i, j, iip)*xx(j)
                        end do
                    end do

                    do j=1, nto
                        if (j == ms2) cycle
                        call accumulate_inner_products(nte, wx, pod(1, j, iip), z(1))
                    end do

                    do i=1, nte
                        xx(i) = xx(i)-z(i)
                    end do

                    call compute_normal_regular_grid(nte, xx, idp, wo(1, 1, iip))

                    it = it+1
                    if (it > 2) exit odd_iteration
                end do odd_iteration

                do i=1, nte
                    pod(i, ms2, iip) = xx(i)
                end do

                if (modn == 1) pod(nte, ms2, iip) = ZERO
            end if
        end do

        ! Reorder if mtrunc is less than nlat-1
        ! case of odd functions
        if (modn == 0) then
            nsho(1) = (nlat-mtrunc)/2
            nsho(2) = (nlat-mtrunc-1)/2
        else
            nsho(1) = (nlat-mtrunc-1)/2
            nsho(2) = (nlat-mtrunc-2)/2
        end if

        do mp1=1, 2
            do j=1, nto
                js = j+nsho(mp1)
                if (js>nto) js = js-nto
                do i=1, nte
                    u(i, js) = pod(i, j, mp1)
                end do
            end do
            do j=1, nto
                do i=1, nte
                    pod(i, j, mp1) = u(i, j)
                end do
            end do
        end do

        call truncate(0, nte, idp, pod(1, 1, 1), nto, ipso(1, 1))
        call truncate(0, nte, idp, pod(1, 1, 2), nto, ipso(1, 2))

        ! Compute the analysis matrices (odd functions)
        do iip=1, 2
            do i=1, nto
                lock = 0
                do j=1, nto
                    summation = ZERO
                    do k=1, nte
                        summation = summation+pod(k, i, iip)*wo(k, j, iip)
                    end do
                    po(i, j, iip) = pod(i, j, iip)
                    zo(j, i, iip) = summation
                    if (abs(summation)>MACHINE_EPSILON .and. lock == 0) then
                        lock = 1
                        jzso(i, iip) = j
                    end if
                end do
            end do
        end do

    end subroutine shpei_lower_utility_routine

    subroutine shpe_lower_utility_routine(nlat, nlon, isym, mtrunc, sx, sy, idxy, ierror, &
        idp, pe, po, ze, zo, ipse, jzse, ipso, jzso, xe, xo, ye, yo)

        integer(ip) :: i
        integer(ip) :: idp
        integer(ip) :: idxy
        integer(ip) :: ierror
        integer(ip) :: iip
        integer(ip) :: ipse
        integer(ip) :: ipso
        integer(ip) :: isym
        integer(ip) :: j
        integer(ip) :: js
        integer(ip) :: jzse
        integer(ip) :: jzso
        integer(ip) :: m
        integer(ip) :: modn
        integer(ip) :: mp1
        integer(ip) :: mpm
        integer(ip) :: mrank
        integer(ip) :: ms2
        integer(ip) :: mtrunc
        integer(ip) :: mxtr
        integer(ip) :: nec
        integer(ip) :: nem
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: noc
        integer(ip) :: nom
        integer(ip) :: nrank
        integer(ip) :: ns2
        integer(ip) :: nshe
        integer(ip) :: nsho
        integer(ip) :: nte
        integer(ip) :: nto
        real(wp) :: pe
        real(wp) :: po
        real(wp) :: sx
        real(wp) :: sy
        real(wp) :: xe
        real(wp) :: xo
        real(wp) :: ye
        real(wp) :: yo
        real(wp) :: ze
        real(wp) :: zo

        dimension sx(idxy, nlon), sy(idxy, nlon), nshe(2), nsho(2), &
            pe(idp, idp, 2), po(idp, idp, 2), ze(idp, idp, 2), zo(idp, idp, 2), &
            ipse(idp, 2), jzse(idp, 2), ipso(idp, 2), jzso(idp, 2), &
            xe(idp, 2), xo(idp, 2), ye(idp, 2), yo(idp, 2)

        ns2 = nlat/2
        modn = nlat-ns2-ns2
        nte = (nlat + 1)/2
        nto = nlat-nte

        if (modn == 0) then
            nshe(1) = (nlat-mtrunc-1)/2
            nshe(2) = (nlat-mtrunc-2)/2
            nsho(1) = (nlat-mtrunc)/2
            nsho(2) = (nlat-mtrunc-1)/2
        else
            nshe(1) = (nlat-mtrunc)/2
            nshe(2) = (nlat-mtrunc-1)/2
            nsho(1) = (nlat-mtrunc-1)/2
            nsho(2) = (nlat-mtrunc-2)/2
        end if
        mxtr = min(nlat-1, nlon/2, mtrunc)
        iip = 2

        main_loop: do mp1=1, mxtr+1
            iip = 3-iip
            if (mxtr == nlat-1 .and. mp1 <= 2) then
                do i=1, nlat
                    sy(i, mp1) = sx(i, mp1)
                end do
                if (mp1 == 2) then
                    sy(1, 2) = ZERO
                    sy(nlat, 2) = ZERO
                end if
                if (3 <= nlon) then
                    sy(1, 3) = ZERO
                    sy(nlat, 3) = ZERO
                    do i=2, nlat-1
                        sy(i, 3) = sx(i, 3)
                    end do
                end if
                cycle main_loop
            end if

            m = mp1-1
            mpm = max(1, m+m)
            ms2 = mp1/2
            mrank = min(nlat-m, nlat-ms2-ms2)
            nrank = nlat-mrank
            nem = (mrank+1)/2-nshe(iip)
            nom = mrank-(mrank+1)/2-nsho(iip)
            nec = nte-nem
            noc = nto-nom

            do i=1, nte
                xe(i, 1) = HALF * (sx(i, mpm)+sx(nlat+1-i, mpm))
                xo(i, 1) = HALF * (sx(i, mpm)-sx(nlat+1-i, mpm))
            end do

            if (mpm<nlon) then
                do i=1, nte
                    xe(i, 2) = HALF * (sx(i, mpm+1)+sx(nlat+1-i, mpm+1))
                    xo(i, 2) = HALF * (sx(i, mpm+1)-sx(nlat+1-i, mpm+1))
                end do
            end if
            if (3*nec<2*nem .or. nem == 0) then
                call matrix_multiplication(nte, nec, idp, pe(1, 1, iip), nte, idp, &
                    ze(1, 1, iip), xe, ye, ipse(1, iip), jzse(1, iip))
                do i=1, nte
                    ye(i, 1) = xe(i, 1)-ye(i, 1)
                end do
                if (mpm<nlon .and. m /= 0) then
                    do i=1, nte
                        ye(i, 2) = xe(i, 2)-ye(i, 2)
                    end do
                end if
            else
                call matrix_multiplication(nte, nem, idp, pe(1, nec+1, iip), nte, idp, &
                    ze(1, nec+1, iip), xe, ye, ipse(nec+1, iip), jzse(nec+1, iip))
            end if
            if (3*noc<2*nom .or. nom == 0) then
                call matrix_multiplication(nto, noc, idp, po(1, 1, iip), nto, idp, &
                    zo(1, 1, iip), xo, yo, ipso(1, iip), jzso(1, iip))
                do i=1, nte
                    yo(i, 1) = xo(i, 1)-yo(i, 1)
                end do
                if (mpm<nlon .and. m /= 0) then
                    do i=1, nte
                        yo(i, 2) = xo(i, 2)-yo(i, 2)
                    end do
                end if
            else
                call matrix_multiplication(nto, nom, idp, po(1, noc+1, iip), nto, idp, &
                    zo(1, noc+1, iip), xo, yo, ipso(noc+1, iip), jzso(noc+1, iip))
            end if
            do i=1, nte
                sy(i, mpm) = ye(i, 1)+yo(i, 1)
                sy(nlat+1-i, mpm) = ye(i, 1)-yo(i, 1)
            end do
            if (mpm<nlon .and. m /= 0) then
                do i=1, nte
                    sy(i, mpm+1) = ye(i, 2)+yo(i, 2)
                    sy(nlat+1-i, mpm+1) = ye(i, 2)-yo(i, 2)
                end do
            end if

        end do main_loop

        js = mxtr+mxtr+2

        do j=js, nlon
            do i=1, nlat
                sy(i, j) = ZERO
            end do
        end do

    end subroutine shpe_lower_utility_routine

    subroutine matrix_multiplication(lr, lc, ld, a, mc, md, b, x, y, is, js)

        real(wp) :: a(ld, *), b(md, *)
        integer(ip) :: i
        integer(ip) :: is(*)
        integer(ip) :: j
        integer(ip) :: js(*)
        integer(ip) :: k
        integer(ip) :: kmx
        integer(ip) :: lc
        integer(ip) :: ld
        integer(ip) :: lr
        integer(ip) :: mc
        integer(ip) :: md
        real(wp) :: sum1
        real(wp) :: sum2
        real(wp) :: x(ld, 2), y(ld, 2)

        kmx = min(lr+1, ld)
        y(1: kmx, :) = ZERO

        if (lc > 0) then
            do i=1, lc
                sum1 = ZERO
                sum2 = ZERO
                do j=js(i), mc
                    sum1 = sum1 + b(j, i)*x(j, 1)
                    sum2 = sum2 + b(j, i)*x(j, 2)
                end do
                do k=is(i), lr
                    y(k, 1) = y(k, 1)+sum1*a(k, i)
                    y(k, 2) = y(k, 2)+sum2*a(k, i)
                end do
            end do
        end if

    end subroutine matrix_multiplication

    subroutine compute_normal_regular_grid(n, x, id, q)

        ! Dummy arguments
        integer(ip), intent(in)    :: n
        real(wp),    intent(inout) :: x(n)
        integer(ip), intent(in)    :: id
        real(wp),    intent(in)    :: q(id, n)

        ! Local variables
        integer(ip) :: i, j
        real(wp)    :: summation, sqs

        ! Normalize x
        sqs = ZERO
        do i=1, n
            summation = ZERO
            do j=1, n
                summation = summation + q(i, j)*x(j)
            end do
            sqs = sqs+summation*x(i)
        end do

        x = x/sqrt(sqs)

    end subroutine compute_normal_regular_grid

    ! Purpose:
    !
    ! Performs the singular value decomposition of a real rectangular matrix.
    !
    !    This routine reduces an m by n matrix a to diagonal form by orthogonal
    !    transformations u and v.  The diagonal elements s(i) are the singular
    !    values of a.  The columns of u are the corresponding left singular
    !    vectors, and the columns of v the right singular vectors.
    !
    !    The form of the singular value decomposition is then
    !
    !      a(mxn) = u(mxm) * s(mxn) * transpose(v(nxn))
    !
    !  Reference:
    !
    !    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
    !    LINPACK User's Guide,
    !    SIAM, 1979,
    !    ISBN13: 978-0-898711-72-1,
    !    LC: QA214.L56.
    !
    !  Parameters:
    !
    !    Input/output, real(wp) a(lda, n).  on input, the m by n
    !    matrix whose singular value decomposition is to be computed.
    !    on output, the matrix has been destroyed.  depending on the user's
    !    requests, the matrix may contain other useful information.
    !
    !    input, integer(ip) lda, the leading dimension of the array a.
    !    lda must be at least n.
    !
    !    input, integer(ip) m, the number of rows of the matrix.
    !
    !    input, integer(ip) n, the number of columns of the matrix a.
    !
    !    output, real(wp) s(mm), where mm = max(m+1, n).  the first
    !    min(m, n) entries of s contain the singular values of a arranged in
    !    descending order of magnitude.
    !
    !    output, real(wp) e(mm), where mm = max(m+1, n).  ordinarily
    !    contains zeros.  however see the discussion of info for exceptions.
    !
    !    output, real(wp) u(ldu, k).  if joba = 1 then k = m;
    !    if 2 <= joba, then k = min(m, n).  u contains the m by m matrix of
    !    left singular vectors.  u is not referenced if joba = 0.  if m <= n
    !    or if joba = 2, then u may be identified with a in the subroutine call.
    !
    !    input, integer(ip) ldu, the leading dimension of the array u.
    !    ldu must be at least m.
    !
    !    output, real(wp) v(ldv, n), the n by n matrix of right singular
    !    vectors.  v is not referenced if job is 0.  if n <= m, then v may be
    !    identified with a in the subroutine call.
    !
    !    input, integer(ip) ldv, the leading dimension of the array v.
    !    ldv must be at least n.
    !
    !    workspace, real(wp) work(m).
    !
    !    input, integer(ip) job, controls the computation of the singular
    !    vectors.  it has the decimal expansion ab with the following meaning:
    !      a =  0, do not compute the left singular vectors.
    !      a =  1, return the m left singular vectors in u.
    !      a >= 2, return the first min(m, n) singular vectors in u.
    !      b =  0, do not compute the right singular vectors.
    !      b =  1, return the right singular vectors in v.
    !
    !    output, integer(ip) info, status indicator.
    !    the singular values (and their corresponding singular vectors)
    !    s(info+1), s(info+2), ..., s(mn) are correct.  here mn = min(m, n).
    !    thus if info is 0, all the singular values and their vectors are
    !    correct.  in any event, the matrix b = u' * a * v is the bidiagonal
    !    matrix with the elements of s on its diagonal and the elements of e on
    !    its superdiagonal.  thus the singular values of a and b are the same.
    !
    subroutine singular_value_decomposition(a, lda, m, n, s, e, u, ldu, v, ldv, work, job, info)

        ! Dummy arguments
        real(wp),    intent(inout) :: a(lda, n)
        integer(ip), intent(in)    :: lda
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: n
        real(wp),    intent(out)   :: s(*)
        real(wp),    intent(out)   :: e(*)
        real(wp),    intent(out)   :: u(ldu, m)
        integer(ip), intent(in)    :: ldu
        real(wp),    intent(out)   :: v(ldv, n)
        integer(ip), intent(in)    :: ldv
        real(wp),    intent(out)   :: work(m)
        integer(ip), intent(in)    :: job
        integer(ip), intent(out)   :: info

        ! Local variables
        real(wp) b
        real(wp) c
        real(wp) cs
        real(wp) el
        real(wp) emm1
        real(wp) f
        real(wp) g
        integer(ip) iter
        integer(ip) j
        integer(ip) job_u
        integer(ip) k
        integer(ip) k_case
        integer(ip) kk
        integer(ip) l
        integer(ip) ll
        integer(ip) lls
        integer(ip) ls
        integer(ip) lu
        integer(ip), parameter :: MAX_ITER = 30
        integer(ip) mm
        integer(ip) mm1
        integer(ip) mn
        integer(ip) nct
        integer(ip) nctp1
        integer(ip) ncu
        integer(ip) nrt
        integer(ip) nrtp1
        real(wp) scale_factor
        real(wp) shift
        real(wp) sl
        real(wp) sm
        real(wp) smm1
        real(wp) sn
        real(wp) t
        real(wp) t1
        real(wp) test
        real(wp) ztest
        logical :: u_desired, v_desired

        !  Determine what is to be computed.
        u_desired = .false.
        v_desired = .false.
        job_u = mod(job, 100)/10

        if (1 < job_u) then
            ncu = min(m, n)
        else
            ncu = m
        end if

        if (job_u /= 0) u_desired = .true.

        if (mod(job, 10) /= 0) v_desired = .true.

        !  Reduce a to bidiagonal form, storing the diagonal elements
        !  in s and the super-diagonal elements in e.
        info = 0
        nct = min(m - 1, n)
        nrt = max(0, min(m, n - 2))
        lu = max(nct, nrt)

        do l = 1, lu

            !  Compute the transformation for the l-th column and
            !  place the l-th diagonal in s(l).
            if (l <= nct) then
                s(l) = get_norm2(m-l+1, a(l, l), 1)
                if (s(l) /= ZERO) then
                    if (a(l, l) /= ZERO) s(l) = sign(s(l), a(l, l))
                    call scale_vector_by_constant( m-l+1, ONE / s(l), a(l, l), 1)
                    a(l, l) = ONE + a(l, l)
                end if
                s(l) = -s(l)
            end if

            do j = l + 1, n

                !  Apply the transformation.
                if (l <= nct .and. s(l) /= ZERO) then
                    t = -get_dot_product( m-l+1, a(l, l), 1, a(l, j), 1) / a(l, l)
                    call daxpy(m-l+1, t, a(l, l), 1, a(l, j), 1)
                end if

                !  Place the l-th row of a into e for the
                !  subsequent calculation of the row transformation.
                e(j) = a(l, j)
            end do

            !  Place the transformation in u for subsequent back multiplication.
            if (u_desired .and. l <= nct) u(l:m, l) = a(l:m, l)

            !  Compute the l-th row transformation and place the
            !  l-th superdiagonal in e(l).
            !
            if (l <= nrt) then
                e(l) = get_norm2(n - l, e(l+1), 1)
                if (e(l) /= ZERO) then
                    if (e(l+1) /= ZERO) then
                        e(l) = sign(e(l), e(l+1))
                    end if
                    call scale_vector_by_constant( n-l, ONE / e(l), e(l+1), 1)
                    e(l+1) = ONE + e(l+1)
                end if

                e(l) = -e(l)
                !
                !  Apply the transformation.
                !
                if (l + 1 <= m .and. e(l) /= ZERO) then

                    work(l+1:m) = ZERO

                    do j = l + 1, n
                        call daxpy(m-l, e(j), a(l+1, j), 1, work(l+1), 1)
                    end do

                    do j = l + 1, n
                        call daxpy(m-l, -e(j)/e(l+1), work(l+1), 1, a(l+1, j), 1)
                    end do

                end if

                !  Place the transformation in v for subsequent back multiplication.
                if (v_desired) v(l+1:n, l) = e(l+1:n)
            end if
        end do

        ! Set up the final bidiagonal matrix of order mn.
        mn = min(m + 1, n)
        nctp1 = nct + 1
        nrtp1 = nrt + 1

        if (nct < n) s(nctp1) = a(nctp1, nctp1)

        if (m < mn) s(mn) = ZERO

        if (nrtp1 < mn) e(nrtp1) = a(nrtp1, mn)

        e(mn) = ZERO

        !  If required, generate u.
        if (u_desired) then

            u(1:m, nctp1:ncu) = ZERO

            do j = nctp1, ncu
                u(j, j) = ONE
            end do

            do ll = 1, nct

                l = nct - ll + 1

                if (s(l) /= ZERO) then

                    do j = l + 1, ncu
                        t = -get_dot_product( m-l+1, u(l, l), 1, u(l, j), 1) / u(l, l)
                        call daxpy(m-l+1, t, u(l, l), 1, u(l, j), 1)
                    end do

                    u(l:m, l) = -u(l:m, l)
                    u(l, l) = ONE + u(l, l)
                    u(1:l-1, l) = ZERO

                else
                    u(1:m, l) = ZERO
                    u(l, l) = ONE
                end if
            end do
        end if

        !  If it is required, generate v.
        if (v_desired) then

            do ll = 1, n
                l = n - ll + 1
                if (l <= nrt .and. e(l) /= ZERO) then
                    do j = l + 1, n
                        t = -get_dot_product( n-l, v(l+1, l), 1, v(l+1, j), 1) / v(l+1, l)
                        call daxpy(n-l, t, v(l+1, l), 1, v(l+1, j), 1)
                    end do
                end if
                v(1:n, l) = ZERO
                v(l, l) = ONE
            end do
        end if

        !  Main iteration loop for the singular values.
        mm = mn
        iter = 0
        main_iteration_loop: do

            if (mn <= 0) exit main_iteration_loop

            !  If too many iterations have been performed, set flag and return.

            if (MAX_ITER <= iter) then
                info = mn
                return
            end if
            !
            !  This section of the program inspects for
            !  negligible elements in the s and e arrays.
            !
            !  On completion the variables k_case and l are set as follows:
            !
            !  k_case = 1     if s(mn) and e(l-1) are negligible and l < mn
            !  k_case = 2     if s(l) is negligible and l < mn
            !  k_case = 3     if e(l-1) is negligible, l < mn, and
            !               s(l), ..., s(mn) are not negligible (qr step).
            !  k_case = 4     if e(mn-1) is negligible (convergence).
            !
            do ll = 1, mn
                l = mn - ll
                if (l == 0) exit
                test = abs(s(l)) + abs(s(l+1))
                ztest = test + abs(e(l))
                if (ztest == test) then
                    e(l) = ZERO
                    exit
                end if
            end do

            if (l == mn - 1) then
                k_case = 4
            else
                do lls = l + 1, mn + 1
                    ls = mn - lls + l + 1

                    if (ls == l) exit

                    test = ZERO

                    if (ls /= mn) test = test + abs(e(ls))

                    if (ls /= l + 1) test = test + abs(e(ls-1))

                    ztest = test + abs(s(ls))

                    if (ztest == test) then
                        s(ls) = ZERO
                        exit
                    end if
                end do

                if (ls == l) then
                    k_case = 3
                else if (ls == mn) then
                    k_case = 1
                else
                    k_case = 2
                    l = ls
                end if
            end if

            l = l + 1

            !  Deflate negligible s(mn).
            select case (k_case)
                case (1)

                    mm1 = mn - 1
                    f = e(mn-1)
                    e(mn-1) = ZERO

                    do kk = l, mm1

                        k = mm1 - kk + l
                        t1 = s(k)
                        call construct_givens_plane_rotation(t1, f, cs, sn)
                        s(k) = t1

                        if (k /= l) then
                            f = -sn * e(k-1)
                            e(k-1) = cs * e(k-1)
                        end if

                        if (v_desired) call apply_plane_rotation(n, v(1, k), 1, v(1, mn), 1, cs, sn)
                    end do
                case (2)

                    f = e(l-1)
                    e(l-1) = ZERO

                    do k = l, mn
                        t1 = s(k)
                        call construct_givens_plane_rotation(t1, f, cs, sn)
                        s(k) = t1
                        f = -sn * e(k)
                        e(k) = cs * e(k)
                        if (u_desired) call apply_plane_rotation(m, u(1, k), 1, u(1, l-1), 1, cs, sn)
                    end do
                case (3)

                    !  Calculate the shift.
                    scale_factor = max(abs(s(mn)), abs(s(mn - 1)), abs(e(mn - 1)), &
                        abs(s(l)), abs(e(l)))

                    sm = s(mn)/scale_factor
                    smm1 = s(mn-1)/scale_factor
                    emm1 = e(mn-1)/scale_factor
                    sl = s(l)/scale_factor
                    el = e(l)/scale_factor
                    b = ((smm1 + sm) * (smm1 - sm) + emm1**2)/TWO
                    c = (sm**2) * (emm1**2)
                    shift = ZERO

                    if (b /= ZERO .or. c /= ZERO) then
                        shift = sqrt(b**2 + c)
                        if (b < ZERO) shift = -shift
                        shift = c / (b + shift)
                    end if

                    f = ( sl + sm) * ( sl - sm) + shift
                    g = sl * el

                    !  Chase zeros.
                    mm1 = mn - 1

                    do k = l, mm1

                        call construct_givens_plane_rotation(f, g, cs, sn)

                        if (k /= l) e(k-1) = f

                        f = cs * s(k) + sn * e(k)
                        e(k) = cs * e(k) - sn * s(k)
                        g = sn * s(k+1)
                        s(k+1) = cs * s(k+1)

                        if (v_desired) call apply_plane_rotation(n, v(1, k), 1, v(1, k+1), 1, cs, sn)

                        call construct_givens_plane_rotation(f, g, cs, sn)

                        s(k) = f
                        f = cs * e(k) + sn * s(k+1)
                        s(k+1) = -sn * e(k) + cs * s(k+1)
                        g = sn * e(k+1)
                        e(k+1) = cs * e(k+1)

                        if (u_desired .and. k < m) call apply_plane_rotation(m, u(1, k), 1, u(1, k+1), 1, cs, sn)

                    end do

                    e(mn-1) = f
                    iter = iter + 1
                case (4)

                    !  Make the singular value nonnegative.
                    if (s(l) < ZERO) then
                        s(l) = -s(l)
                        if (v_desired) v(1:n, l) = -v(1:n, l)
                    end if

                    !  Order the singular value.
                    do

                        if (l == mm) exit

                        if (s(l+1) <= s(l)) exit

                        t = s(l)
                        s(l) = s(l+1)
                        s(l+1) = t

                        if (v_desired .and. l < n) call swap_vectors( n, v(1, l), 1, v(1, l+1), 1)

                        if (u_desired .and. l < m) call swap_vectors(m, u(1, l), 1, u(1, l+1), 1)
                        l = l + 1
                    end do
                    iter = 0
                    mn = mn - 1
            end select
        end do main_iteration_loop

    end subroutine singular_value_decomposition

    ! Purpose:
    !
    ! Computes constant times a vector plus a vector.
    !
    ! Jack dongarra, linpack, 3/11/78.
    ! Modified 12/3/93, array(1) declarations changed to array(*)
    ! Modified 01/27/17, whole array operations to aid compiler optimization
    !
    subroutine daxpy(n, da, dx, incx, dy, incy)

        ! Dummy arguments
        integer(ip), intent(in)    :: n
        real(wp),    intent(in)    :: da
        real(wp),    intent(in)    :: dx(*)
        integer(ip), intent(in)    :: incx
        real(wp),    intent(inout) :: dy(*)
        integer(ip), intent(in)    :: incy

        ! Local variables
        integer(ip) :: i, ix, iy, m

        if (n <= 0) then
            return
        else if (da == ZERO) then
            return
        else if (incx /= 1 .or. incy /= 1) then

            !  Code for unequal increments or equal increments
            !  not equal to 1.
            if (0 <= incx) then
                ix = 1
            else
                ix = (-n + 1) * incx + 1
            end if

            if (0 <= incy) then
                iy = 1
            else
                iy = (-n + 1) * incy + 1
            end if

            do i = 1, n
                dy(iy) = dy(iy) + da * dx(ix)
                ix = ix + incx
                iy = iy + incy
            end do
        else
            !  Code for both increments equal to 1.
            m = mod(n, 4)

            dy(1:m) = dy(1:m) + da * dx(1:m)

            do i = m + 1, n, 4
                dy(i) = dy(i) + da * dx(i)
                dy(i+1) = dy(i+1) + da * dx(i+1)
                dy(i+2) = dy(i+2) + da * dx(i+2)
                dy(i+3) = dy(i+3) + da * dx(i+3)
            end do
        end if

    end subroutine daxpy

    ! Purpose:
    !
    ! Forms the dot product of two vectors.
    ! Jack dongarra, linpack, 3/11/78.
    ! Modified 12/3/93, array(1) declarations changed to array(*)
    ! Modified 01/27/17, the function now wraps around the intrinsic dot_product
    !
    pure function get_dot_product(n, dx, incx, dy, incy) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: n
        real(wp),    intent(in) :: dx(*)
        integer(ip), intent(in) :: incx
        real(wp),    intent(in) :: dy(*)
        integer(ip), intent(in) :: incy
        real(wp)                :: return_value

        ! Local variables
        integer(ip) :: x1, xn, xi
        integer(ip) :: y1, yn, yi

        if (0 < incx) then
            x1 = 1
            xn = 1 + (n - 1) * incx
            xi = incx
        else
            x1 = 1 + (n - 1) * incx
            xn = 1
            xi = - incx
        end if

        if (0 < incy) then
            y1 = 1
            yn = 1 + (n - 1) * incy
            yi = incy
        else
            y1 = 1 + (n - 1) * incy
            yn = 1
            yi = - incy
        end if

        !  Let the intrinsic function dot_product take care of optimization.
        return_value = dot_product(dx(x1:xn:xi), dy(y1:yn:yi))

    end function get_dot_product

    ! Purpose:
    !
    !  Returns the euclidean norm of a vector via the function
    !  name, so that
    !
    !     return_value := sqrt( transpose(x) * x)
    !
    ! This version written on 25-October-1982.
    ! Modified on 14-October-1993 to inline the call to DLASSQ.
    ! Sven Hammarling, Nag Ltd.
    !
    ! Modified 01/27/17, function now wraps around the intrinsic norm2
    !
    pure function get_norm2(n, x, incx) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: n
        real(wp),    intent(in) :: x(*)
        integer(ip), intent(in) :: incx
        real(wp)                :: return_value

        ! Local variables
        integer(ip) :: x1, xn, xi

        if (0 < incx) then
            x1 = 1
            xn = 1 + (n - 1) * incx
            xi = incx
        else
            x1 = 1 + (n - 1) * incx
            xn = 1
            xi = -incx
        end if

        !  Let the intrinsic function norm2 take care of optimization.
        return_value = norm2(x(x1:xn:xi))

    end function get_norm2

    ! Purpose:
    !
    ! Applies a plane rotation.
    ! Jack dongarra, linpack, 3/11/78.
    ! Modified 12/3/93, array(1) declarations changed to array(*)
    !
    subroutine apply_plane_rotation(n, x, incx, y, incy, c, s)

        ! Dummy arguments
        integer(ip), intent(in)    :: n
        real(wp),    intent(inout) :: x(*)
        integer(ip), intent(in)    :: incx
        real(wp),    intent(inout) :: y(*)
        integer(ip), intent(in)    :: incy
        real(wp),    intent(in)    :: c
        real(wp),    intent(in)    :: s

        ! Local variables
        integer(ip) :: i, ix, iy
        real(wp)    :: temp

        if (n <= 0) then
            return
        else if (incx == 1 .and. incy == 1) then
            do i = 1, n
                temp = c * x(i) + s * y(i)
                y(i) = c * y(i) - s * x(i)
                x(i) = temp
            end do
        else
            if (0 <= incx) then
                ix = 1
            else
                ix = (-n + 1) * incx + 1
            end if

            if (0 <= incy) then
                iy = 1
            else
                iy = (-n + 1) * incy + 1
            end if

            do i = 1, n
                temp = c * x(ix) + s * y(iy)
                y(iy) = c * y(iy) - s * x(ix)
                x(ix) = temp
                ix = ix + incx
                iy = iy + incy
            end do
        end if

    end subroutine apply_plane_rotation

    ! Purpose:
    !
    ! Constructs a Givens plane rotation.
    !
    ! Given values a and b, this routine computes
    !
    !    sigma = sign(a) if abs(a) >  abs(b)
    !          = sign(b) if abs(a) <= abs(b);
    !
    !    r     = sigma * (a**2 + b**2);
    !
    !    c = a / r if r is not 0
    !      = 1     if r is 0;
    !
    !    s = b / r if r is not 0,
    !        0     if r is 0.
    !
    !    The computed numbers then satisfy the equation
    !
    !    (  c  s) ( a) = ( r)
    !    ( -s  c) ( b) = ( 0)
    !
    !    The routine also computes
    !
    !    z = s     if abs(a) > abs(b),
    !      = 1 / c if abs(a) <= abs(b) and c is not 0,
    !      = 1     if c is 0.
    !
    !    The single value z encodes c and s, and hence the rotation:
    !
    !    if z = 1, set c = 0 and s = 1;
    !    if abs(z) < 1, set c = sqrt(1 - z**2) and s = z;
    !    if abs(z) > 1, set c = 1/ z and s = sqrt(1 - c**2);
    !
    !  Reference:
    !
    !    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
    !    LINPACK User's Guide,
    !    SIAM, 1979,
    !    ISBN13: 978-0-898711-72-1,
    !    LC: QA214.L56.
    !
    !    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
    !    Algorithm 539,
    !    Basic Linear Algebra Subprograms for Fortran Usage,
    !    ACM Transactions on Mathematical Software,
    !    Volume 5, Number 3, September 1979, pages 308-323.
    !
    !  Dummy arguments:
    !
    !    input/output, real sa, sb.  on input, sa and sb are the values
    !    a and b.  on output, sa is overwritten with r, and sb is
    !    overwritten with z.
    !
    !    Output, real c, s, the cosine and sine of the
    !    Givens rotation.
    !
    subroutine construct_givens_plane_rotation(sa, sb, c, s)

        ! Dummy arguments
        real(wp), intent(inout) :: sa
        real(wp), intent(inout) :: sb
        real(wp), intent(out) :: s
        real(wp), intent(out) :: c

        ! Local variables
        real(wp) :: scale_factor, r, z, roe

        if (abs(sb) < abs(sa)) then
            roe = sa
        else
            roe = sb
        end if

        scale_factor = abs(sa) + abs(sb)

        if (scale_factor == ZERO) then
            c = ONE
            s = ZERO
            r = ZERO
        else
            r = scale_factor * hypot((sa/scale_factor), (sb/scale_factor))
            r = sign(ONE, roe) * r
            c = sa/r
            s = sb/r
        end if

        if (ZERO < abs(c) .and. abs(c) <= s) then
            z = ONE/c
        else
            z = s
        end if

        sa = r
        sb = z

    end subroutine construct_givens_plane_rotation

    ! Purpose:
    !
    ! Scales a vector by a constant.
    !
    ! Jack dongarra, linpack, 3/11/78.
    ! Modified 3/93 to return if incx <= 0.0
    ! Modified 12/3/93, array(1) declarations changed to array(*)
    ! Modified 01/27/17, uses array operations to aid compiler optimization
    !
    subroutine scale_vector_by_constant(n, sa, x, incx)

        ! Dummy arguments
        integer(ip), intent(in)    :: n
        real(wp),    intent(in)    :: sa
        real(wp),    intent(inout) :: x(*)
        integer(ip), intent(in)    :: incx

        ! Local variables
        integer(ip) :: i, ix, m

        if (n <= 0) then
            return
        else if (incx == 1) then

            m = mod(n, 5)

            x(1:m) = sa * x(1:m)

            do i = m+1, n, 5
                x(i) = sa * x(i)
                x(i+1) = sa * x(i+1)
                x(i+2) = sa * x(i+2)
                x(i+3) = sa * x(i+3)
                x(i+4) = sa * x(i+4)
            end do
        else
            if (0 <= incx) then
                ix = 1
            else
                ix = (-n + 1) * incx + 1
            end if

            do i = 1, n
                x(ix) = sa * x(ix)
                ix = ix + incx
            end do

        end if

    end subroutine scale_vector_by_constant

    ! Purpose:
    !
    ! Interchanges two vectors.
    ! uses unrolled loops for increments equal one.
    ! Jack dongarra, linpack, 3/11/78.
    ! Modified 12/3/93, array(1) declarations changed to array(*)
    ! Modified 01/27/17, whole array operations to improve compiler optimization
    !
    subroutine swap_vectors(n, x, incx, y, incy)

        ! Dummy arguments
        integer(ip), intent(in)    :: n
        real(wp),    intent(inout) :: x(*)
        integer(ip), intent(in)    :: incx
        real(wp),    intent(inout) :: y(*)
        integer(ip), intent(in)    :: incy

        ! Local variables
        integer(ip) :: m, i, ix, iy
        real(wp)    :: temp

        if (n <= 0) then
            return
        else if (incx == 1 .and. incy == 1) then
            m = mod(n, 3)
            do i = 1, m
                temp = x(i)
                x(i) = y(i)
                y(i) = temp
            end do

            do i = m + 1, n, 3
                temp = x(i)
                x(i) = y(i)
                y(i) = temp

                temp = x(i+1)
                x(i+1) = y(i+1)
                y(i+1) = temp

                temp = x(i+2)
                x(i+2) = y(i+2)
                y(i+2) = temp
            end do
        else

            if (0 <= incx) then
                ix = 1
            else
                ix = (-n + 1) * incx + 1
            end if

            if (0 <= incy) then
                iy = 1
            else
                iy = (-n + 1) * incy + 1
            end if

            do i = 1, n
                temp = x(ix)
                x(ix) = y(iy)
                y(iy) = temp
                ix = ix + incx
                iy = iy + incy
            end do
        end if

    end subroutine swap_vectors

end submodule scalar_projection_regular_grid


SUBROUTINE fsparv(kv,km,g,kdiag)
!
! This subroutine assembles element matrices into a symmetric skyline
! global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::g(:),kdiag(:)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::kv(:)
 INTEGER::i,idof,k,j,iw,ival
 idof=UBOUND(g,1)
 DO i=1,idof
   k=g(i)
   IF(k/=0)THEN
     DO j=1,idof
       IF(g(j)/=0)THEN
         iw=k-g(j)
         IF(iw>=0)THEN
           ival=kdiag(k)-iw
           kv(ival)=kv(ival)+km(i,j)
         END IF
       END IF
     END DO
   END IF
 END DO
RETURN
END SUBROUTINE fsparv


module Mod_plcd_SimoJU
   use typre
   use Mod_plcd_ComparisonCriteria
   use Mod_Plcd_ConstitutiveTensor
   implicit none

   type, extends(ComparisonCriteria) :: SimoJu

      contains
      procedure :: Evaluate => SimoJuEvaluate
      procedure :: ComputeTauValueFromUniaxialStressTest => SimoJuComputeTauValueFromUniaxialStressTest
   end type
contains
   subroutine SimoJuComputeTauValueFromUniaxialStressTest(a,UniaxialStressLimit,CT,tau)
      class(SimoJu) :: a
      real(rp) :: UniaxialStressLimit,tau
      class(ConstitutiveTensor) :: CT

      real(rp) :: Cnorm
      real(rp) :: Direction(3), E0

      Direction = (/1.0_rp, 0.0_rp, 0.0_rp/)
      call CT%GetYoungModulusForDirection(Direction,E0)
!
      call CT%GetCNorm(Cnorm)

      Tau = UniaxialStressLimit*sqrt(1.5_rp*Cnorm/E0)

   end subroutine

   subroutine SimoJuEvaluate(a,Stress,Strain,CT,tau)
      class(SimoJU) :: a
      real(rp) :: Stress(:), Strain(:), tau
      class(ConstitutiveTensor) :: CT

       real(rp) :: Cnorm

       call CT%GetCNorm(Cnorm)

      Tau = sqrt(dot_product(Stress,strain))*sqrt(1.5_rp*Cnorm)

   end subroutine

end module

module Mod_plcd_VonMises
   use typre
   use Mod_plcd_ComparisonCriteria
   use Mod_Plcd_ConstitutiveTensor
   implicit none

   type, extends(ComparisonCriteria) :: VonMises
      contains
      procedure :: Evaluate => VonMisesEvaluate
      procedure :: ComputeTauValueFromUniaxialStressTest => VonMisesComputeTauValueFromUniaxialStressTest
   end type
contains

   subroutine VonMisesComputeTauValueFromUniaxialStressTest(a,UniaxialStressLimit,CT,tau)
      class(VonMises) :: a
      real(rp) :: UniaxialStressLimit,tau
      class(ConstitutiveTensor) :: CT

      Tau = UniaxialStressLimit
   end subroutine

   subroutine VonMisesEvaluate(a,Stress,Strain,CT,tau)
      class(VonMises) :: a
      real(rp) :: Stress(:),Strain(:),tau
      class(ConstitutiveTensor) :: CT

      real(rp) :: deviatoricStress(size(Stress,1)),DeviatoricStressNorm,meanStress

      call CT%ComputeMeanStress(stress,meanstress)

      deviatoricStress = stress
      call CT%AddSphericalComponent(-meanstress,DeviatoricStress)

      call CT%ComputeStressNorm(DeviatoricStress,DeviatoricStressNorm)

      Tau = sqrt(3.0_rp/2.0_rp)*DeviatoricStressNorm
   end subroutine

end module


    program test
    USE, INTRINSIC :: ISO_C_BINDING
    USE OPENST
    use omp_lib
    REAL (C_DOUBLE), TARGET, ALLOCATABLE :: U(:,:,:), V(:,:,:)
    CHARACTER (C_CHAR), TARGET, ALLOCATABLE :: LSM_UNLOCKED(:,:,:)
    INTEGER (C_SIZE_T) :: NI , NJ, NK
    REAL (C_DOUBLE) :: HI, HJ, HK, SRCI, SRCJ, SRCK
    TYPE (C_PTR) :: U_PTR, V_PTR, LSM_UNLOCKED_PTR, converged_ptr, it_ptr
    REAL (C_DOUBLE) :: EPS, CHECK, di, dj, dk, dist
    REAL (C_DOUBLE) :: L1, L2, LINF, Umin, Umean, Umax
    INTEGER (C_INT) :: max_iter, errcode
    INTEGER (C_INT), TARGET :: it, converged
    INTEGER (C_SIZE_T):: i,j,k
    double precision :: start, finish

    NI = 50
    NJ = 50
    NK = 50

    SRCI = 0.5
    SRCJ = 0.5
    SRCK = 0.5
    HI = 1.0 / (NI - 1)
    HJ = 1.0 / (NJ - 1)
    HK = 1.0 / (NK - 1)
    max_iter = 10
    EPS = 0.01 * MIN(HI,HJ,HK);
    print '("GRID: ",i3," x ",i3," x ",i3)',NI,NJ,NK
    print '("GRID STEP: ",E15.6," x ",E15.6," x ",E15.6)',HI,HJ,HK
    print '("EPS: ",E15.6)',EPS

    ALLOCATE ( U (NI, NJ, NK) )
    ALLOCATE ( V (NI, NJ, NK) )
    ALLOCATE ( LSM_UNLOCKED (NI, NJ, NK) )

    U_PTR = C_LOC(U)
    V_PTR = C_LOC(V)
    LSM_UNLOCKED_PTR = C_LOC(LSM_UNLOCKED)
    it_ptr = C_LOC(it)
    converged_ptr = C_LOC(converged)

    do k = 1,NK
        do j = 1,NJ
            do i = 1,NI
                V(i,j,k) = 1.0
            end do
        end do
    end do

    start = omp_get_wtime()
    V = RESHAPE( V, [NI,NJ,NK], order=[3,2,1])
    finish = omp_get_wtime()
    print '("RESHAPE C INPUT: ",f12.6," seconds.")',finish-start

    start = omp_get_wtime()
    errcode = OpenST_LSM3D(U_PTR,LSM_UNLOCKED_PTR,V_PTR,NI,NJ,NK,HI,HJ,HK,SRCI,SRCJ,SRCK,EPS,max_iter,it_ptr,converged_ptr)
    finish = omp_get_wtime()
    print '("LSM3D: ",f12.6," seconds, ",i3," iterations, converged ",i1)',finish-start,it,converged

    if (errcode.NE.0) then
        print '("OPENST_ERROR: code ",i2)',errcode
        STOP 1
    end if

    start = omp_get_wtime()
    U = RESHAPE( U, [NI,NJ,NK], order=[3,2,1])
    finish = omp_get_wtime()
    print '("RESHAPE C OUTPUT: ",f12.6," seconds.")',finish-start

    it = 0
    L1 = 0.0
    L2 = 0.0
    Umean = 0.0
    do k = 1,NK
        do j = 1,NJ
            do i = 1,NI
                di = SRCI - DBLE(i - 1) * HI
                dj = SRCJ - DBLE(j - 1) * HJ
                dk = SRCK - DBLE(k - 1) * HK
                dist = SQRT(di * di + dj * dj + dk * dk)
                CHECK = ABS(U(i,j,k) - dist)
                L1 = L1 + CHECK
                L2 = L2 + CHECK * CHECK
                Umean = Umean + U(i,j,k)
                if (it > 0) then
                    LINF = MAX(CHECK,LINF)
                    Umin = MIN(U(i,j,k),Umin)
                    Umax = MAX(U(i,j,k),Umax)
                else
                    LINF = CHECK
                    Umin = U(i,j,k)
                    Umax = U(i,j,k)
                end if
                it = it + 1
            end do
        end do
    end do
    L1 = L1 / DBLE(NI * NJ * NK)
    L2 = L2 / DBLE(NI * NJ * NK)
    Umean = Umean / DBLE(NI * NJ * NK)

    print '(A, T10, E15.6)', "L1:", L1, "L2:", L2, "LINF:", LINF
    print '(A, T10, E15.6)', "Umin:", Umin, "Umean:", Umean, "Umax:", Umax

    end program


!  cfd_upwind.f90
!
!  FUNCTIONS:
!  cfd_upwind - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: cfd_upwind
!  by mehrdad baba hoseinpour
!  PURPOSE:  Entry point for the console application.
!  beyond sky!
!****************************************************************************

program wave_upwind
implicit none
integer::i,n
integer,parameter:: ix=201,nt=400
real::u(nt,ix),a,dt,dx,l,pi,u1(nt,ix)
pi=2*asin(1.d0)
a=0.01
dt=0.04
l=1
dx=l/(ix-1)
print*,'qourant number is = ',a*dt/dx

!exact_solution
do n=1,nt
 do i=1,ix
    u1(n,i)= sin(2*pi*(i-1)*(dx-a*dt)*5)
 end do
end do

!initial condition
do i=1,ix
    u(1,i)=sin(2*pi*(i-1)*dx*5)   ! 1,nt  u(n,i) -a*n
end do
do n=1,nt-1
    do i=2,ix-1
        u(n+1,i)=u(n,i)-a*dt/dx*(u(n,i)-u(n,i-1))
    end do
    !periodic condition
    u(n+1,1)=u(n,1)-a*dt/dx*(u(n,1)-u(n,ix))
    u(n+1,ix)=u(n+1,1)
end do
open (1,file='analysis_result_upwind.plt')   !  result analysis
do n=1,nt
    write(1,*)'variables="x","u"'
    write(1,*)'zone'
    do i=1,ix
        write(1,*) dx*(i-1),u1(n,i)
    end do
end do
open (1,file='computational_result_upwind.plt')   !  result computational
do n=1,nt
    write(1,*)'variables="x","u"'
    write(1,*)'zone'
    do i=1,ix
        write(1,*) dx*(i-1),u(n,i)
    end do
end do
print*,">>> please Inter <<<"
pause
    end program wave_upwind


program Example
  implicit none

  real :: r
  integer :: a, b

  do
     call random_number(r)
     a = int(r * 20)
     write(*,*) a
     if (a == 10) exit
     call random_number(r)
     b = int(r * 20)
     write(*,*) b
  end do

end program Example


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     1/976
c
c     a program for testing all vector laplacian and its inverse
c
c     (1) first set the vector function (rotation about equator) using
c         v = cos(phi) and w = -cos(theta)*sin(phi)
c
c     (2) set vector laplacian ananlytically
c         vlap = -2.*cos(phi)=-2.*v, wlap = -2.*w
c         (i.e., L(v,w) = -2.*(v,w) so (v,w) is an eigenfunction for the
c         vector Laplacian with eigenvalue -2.
c
c     (3) compute the coefficients br,bi,cr,ci of (v,w) using vector analysis
c
c     (3) compute the vector laplacian of (v,w) using vlapec,vlapes,vlapgc,vlapgs
c
c     (4) compare (3) with (2)
c
c     (5) invert (4) and compare with (v,w)
c
      program tvlap
c
c     set dimensions with parameter statements
c
      parameter(nnlat=29 ,nnlon= 16, nnt = 1)
      parameter (mmdbc = (nnlon+2)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav=15*nnlat*nnlat*nnlon)
      parameter (lldwork = 4*nnlat*nnlat )
      double precision dwork(lldwork)
      dimension work(lleng),wsave(llsav)
      dimension br(mmdbc,nnlat,nnt),bi(mmdbc,nnlat,nnt)
      dimension cr(mmdbc,nnlat,nnt),ci(mmdbc,nnlat,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension vlap(nnlat,nnlon,nnt),wlap(nnlat,nnlon,nnt)

      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      nmax = max0(nlat,nlon)
      mdbc = mmdbc

      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all divergence and inverse divergence subroutines
c
      do icase=1,4
      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c     set vector field v,w
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    if (k.eq.1) then
	    v(i,j,k) = cosp
	    w(i,j,k) = -cost*sinp
	    vlap(i,j,k) = -2.0*v(i,j,k)
	    wlap(i,j,k) = -2.0*w(i,j,k)
	    end if
	  end do
	end do
      end do

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     call aout(vlap(1,1,kk),"vlap",nlat,nlon)
c     call aout(wlap(1,1,kk),"wlap",nlat,nlon)
      end do
      end if

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze vector field
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(br(1,1,kk),"  br",nlat,nlat)
c     call aout(bi(1,1,kk),"  bi",nlat,nlat)
c     call aout(cr(1,1,kk),"  cr",nlat,nlat)
c     call aout(ci(1,1,kk),"  ci",nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vlapec(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vlap")
      call iout(ierror,"ierr")

      else if (icase.eq.2) then

      call name("**es")
c
c     analyze vector field
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaes(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vhae")
      call iout(ierror,"ierr")

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vlapes(nlat,nlon,isym,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vlap")
      call iout(ierror,"ierr")

      else if (icase .eq.3 ) then

      call name("**gc")
c
c     analyze vector field
c
      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhagc(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(br(1,1,kk),"  br",nlat,nlat)
c     call aout(bi(1,1,kk),"  bi",nlat,nlat)
c     call aout(cr(1,1,kk),"  cr",nlat,nlat)
c     call aout(ci(1,1,kk),"  ci",nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vlapgc(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vlap")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")
c
c     analyze vector field
c
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhags(nlat,nlon,ityp,nt,v,w,nlat,nlon,br,bi,cr,ci,mdbc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(br(1,1,kk),"  br",nlat,nlat)
c     call aout(bi(1,1,kk),"  bi",nlat,nlat)
c     call aout(cr(1,1,kk),"  cr",nlat,nlat)
c     call aout(ci(1,1,kk),"  ci",nlat,nlat)
c     end do
c     end if
c
c     compute vector laplacian
c

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vlapgs(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vlap")
      call iout(ierror,"ierr")

      end if

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,"**kk")
c     call aout(vlap(1,1,kk),"vlap",nlat,nlon)
c     call aout(wlap(1,1,kk),"wlap",nlat,nlon)
      end do
      end if
c
c     compute "error" in vlap,wlap
c
      err2v = 0.0
      err2w =0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    if (k.eq.1) then
	      err2v = err2v+(vlap(i,j,k)+2.*v(i,j,k))**2
	      err2w = err2w+(wlap(i,j,k)+2.*w(i,j,k))**2
	    end if
	  end do
	end do
      end do
c
c     set and print least squares error in vlap,wlap
c
      err2v = sqrt(err2v/(nt*nlat*nlon))
      err2w = sqrt(err2w/(nt*nlon*nlat))
      call vout(err2v,"errv")
      call vout(err2w,"errw")
c
c     now recompute (v,w) inverting (vlap,wlap) ivlap codes
c
      do kk=1,nt
      do j=1,nlon
      do i=1,nlat
      v(i,j,kk) = 0.0
      w(i,j,kk) = 0.0
      end do
      end do
      end do

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze vector field (vlap,wlap)
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call ivlapec(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("ivlp")
      call iout(ierror,"ierr")

      else if (icase.eq.2) then

      call name("**es")
c
c     analyze vector field (vlap,wlap)
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaes(nlat,nlon,isym,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call ivlapes(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("ivlp")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call name("**gc")

c
c     analyze vector field (vlap,wlap)
c
      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhagc(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call vhsgci(nlat,nlon,wsave,lsave,work,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call ivlapgc(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("ivlp")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")

c
c     analyze vector field (vlap,wlap)
c
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhags(nlat,nlon,ityp,nt,vlap,wlap,nlat,nlon,
     +br,bi,cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call ivlapgs(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,
     +cr,ci,mdbc,nlat,wsave,lsave,work,lwork,ierror)
      call name("ivlp")
      call iout(ierror,"ierr")

      end if

      if (nmax.lt.10) then
      do kk=1,nt
      call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
      end do
      end if

c
c     compare this v,w with original
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    if (k.eq.1) then
	      ve = cosp
	      we = -cost*sinp
	    end if
	    err2v = err2v + (v(i,j,k)-ve)**2
	    err2w = err2w + (w(i,j,k)-we)**2
	  end do
	end do
      end do
      err2v = sqrt(err2v/(nlat*nlon*nt))
      err2w = sqrt(err2w/(nlat*nlon*nt))
      call vout(err2v,"errv")
      call vout(err2w,"errw")

c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


!      .................................................................
       SUBROUTINE LAGRANGE_MULT(NCONS,H20,ACON20,alagCON_0,alagCON,NDIM)
!      .................................................................
!      INPUTS: NCONS,H20,ACON20
!      .................................................................
       USE VAPHFB_PAR
       implicit real*8 (a-h,o-z)

        DIMENSION alagCON_0(NCONSMAX)
        DIMENSION alagCON(NCONSMAX)
!       ...................................
        DIMENSION ACON20(NCONS*NDIM*NDIM)
        DIMENSION H20(NDIM,NDIM)
        DIMENSION AUX1(((NCONS+1)*NCONS/2)*NDIM*NDIM)
        DIMENSION AUX2(NCONS*NDIM*NDIM)
        DIMENSION Amatrix(NCONS,NCONS),Bmatrix(NCONS)
        DIMENSION IPIV(NCONS)

        ll=0
        do ii=1,NCONS
         indi=(ii-1)*NDIM*NDIM+1

!        ............ number of constraint terms
         do jj=ii,NCONS
            indj=(jj-1)*NDIM*NDIM+1
            ll=ll+1
            indl=(ll-1)*NDIM*NDIM+1

!      ............ AUX1 = ACON20 * ACON20
        call DGEMM ('n','t',NDIM,NDIM,NDIM,1.d0,ACON20(indi), &
     &               NDIM,ACON20(indj),NDIM,0.d0,AUX1(indl),NDIM)

         end do

!      ............ AUX2 = H20 * ACON20
         call DGEMM ('n','t',NDIM,NDIM,NDIM,1.d0,               &
     &        H20,NDIM,ACON20(indi),NDIM,0.d0,AUX2(indi),NDIM)

        end do

        ll=0
        do ii=1,NCONS
         indi=(ii-1)*NDIM*NDIM+1
         do jj=ii,NCONS
         ll=ll+1
         indl=(ll-1)*NDIM*NDIM+1

           Amatrix(jj,ii)=zero
           do mm=1,NDIM
              idig=(mm-1)*NDIM+mm-1
              Amatrix(jj,ii)=Amatrix(jj,ii)+AUX1(indl+idig)
           end do
              Amatrix(ii,jj)=Amatrix(jj,ii)
         end do

         Bmatrix(ii)=zero
           do mm=1,NDIM
              idig=(mm-1)*NDIM+mm-1
              Bmatrix(ii)=Bmatrix(ii)+AUX2(indi+idig)
           end do

        end do

        call DGESV(NCONS,1,Amatrix,NCONS,IPIV,Bmatrix,NCONS,INFO)

        do ii=1,NCONS
             alagCON(ii)=Bmatrix(ii)
        end do

        if (INFO.ne.0) then
         do ii=1,NCONS
          alagCON(ii)=alagCON_0(ii)
         end do
        end if

        do ii=1,NCONS
          alagCON_0(ii)=alagCON(ii)
        end do

        END SUBROUTINE


*DECK SVD
      SUBROUTINE SVD (NM, M, N, A, W, MATU, U, MATV, V, IERR, RV1)
C***BEGIN PROLOGUE  SVD
C***SUBSIDIARY
C***PURPOSE  Perform the singular value decomposition of a rectangular
C            matrix.
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SVD-S)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure SVD,
C     NUM. MATH. 14, 403-420(1970) by Golub and Reinsch.
C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
C
C     This subroutine determines the singular value decomposition
C          T
C     A=USV  of a REAL M by N rectangular matrix.  Householder
C     bidiagonalization and a variant of the QR algorithm are used.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, U and V, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C          Note that NM must be at least as large as the maximum
C          of M and N.
C
C        M is the number of rows of A and U.
C
C        N is the number of columns of A and U and the order of V.
C
C        A contains the rectangular input matrix to be decomposed.  A is
C          a two-dimensional REAL array, dimensioned A(NM,N).
C
C        MATU should be set to .TRUE. if the U matrix in the
C          decomposition is desired, and to .FALSE. otherwise.
C          MATU is a LOGICAL variable.
C
C        MATV should be set to .TRUE. if the V matrix in the
C          decomposition is desired, and to .FALSE. otherwise.
C          MATV is a LOGICAL variable.
C
C     On Output
C
C        A is unaltered (unless overwritten by U or V).
C
C        W contains the N (non-negative) singular values of A (the
C          diagonal elements of S).  They are unordered.  If an
C          error exit is made, the singular values should be correct
C          for indices IERR+1, IERR+2, ..., N.  W is a one-dimensional
C          REAL array, dimensioned W(N).
C
C        U contains the matrix U (orthogonal column vectors) of the
C          decomposition if MATU has been set to .TRUE.  Otherwise,
C          U is used as a temporary array.  U may coincide with A.
C          If an error exit is made, the columns of U corresponding
C          to indices of correct singular values should be correct.
C          U is a two-dimensional REAL array, dimensioned U(NM,N).
C
C        V contains the matrix V (orthogonal) of the decomposition if
C          MATV has been set to .TRUE.  Otherwise, V is not referenced.
C          V may also coincide with A if U does not.  If an error
C          exit is made, the columns of V corresponding to indices of
C          correct singular values should be correct.  V is a two-
C          dimensional REAL array, dimensioned V(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          K          if the K-th singular value has not been
C                     determined after 30 iterations.
C
C        RV1 is a one-dimensional REAL array used for temporary storage,
C          dimensioned RV1(N).
C
C     CALLS PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***SEE ALSO  EISDOC
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   811101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  SVD
C
      INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR
      REAL A(NM,*),W(*),U(NM,*),V(NM,*),RV1(*)
      REAL C,F,G,H,S,X,Y,Z,SCALE,S1
      REAL PYTHAG
      LOGICAL MATU,MATV
C
C***FIRST EXECUTABLE STATEMENT  SVD
      IERR = 0
C
      DO 100 I = 1, M
C
         DO 100 J = 1, N
            U(I,J) = A(I,J)
  100 CONTINUE
C     .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
      G = 0.0E0
      SCALE = 0.0E0
      S1 = 0.0E0
C
      DO 300 I = 1, N
         L = I + 1
         RV1(I) = SCALE * G
         G = 0.0E0
         S = 0.0E0
         SCALE = 0.0E0
         IF (I .GT. M) GO TO 210
C
         DO 120 K = I, M
  120    SCALE = SCALE + ABS(U(K,I))
C
         IF (SCALE .EQ. 0.0E0) GO TO 210
C
         DO 130 K = I, M
            U(K,I) = U(K,I) / SCALE
            S = S + U(K,I)**2
  130    CONTINUE
C
         F = U(I,I)
         G = -SIGN(SQRT(S),F)
         H = F * G - S
         U(I,I) = F - G
         IF (I .EQ. N) GO TO 190
C
         DO 150 J = L, N
            S = 0.0E0
C
            DO 140 K = I, M
  140       S = S + U(K,I) * U(K,J)
C
            F = S / H
C
            DO 150 K = I, M
               U(K,J) = U(K,J) + F * U(K,I)
  150    CONTINUE
C
  190    DO 200 K = I, M
  200    U(K,I) = SCALE * U(K,I)
C
  210    W(I) = SCALE * G
         G = 0.0E0
         S = 0.0E0
         SCALE = 0.0E0
         IF (I .GT. M .OR. I .EQ. N) GO TO 290
C
         DO 220 K = L, N
  220    SCALE = SCALE + ABS(U(I,K))
C
         IF (SCALE .EQ. 0.0E0) GO TO 290
C
         DO 230 K = L, N
            U(I,K) = U(I,K) / SCALE
            S = S + U(I,K)**2
  230    CONTINUE
C
         F = U(I,L)
         G = -SIGN(SQRT(S),F)
         H = F * G - S
         U(I,L) = F - G
C
         DO 240 K = L, N
  240    RV1(K) = U(I,K) / H
C
         IF (I .EQ. M) GO TO 270
C
         DO 260 J = L, M
            S = 0.0E0
C
            DO 250 K = L, N
  250       S = S + U(J,K) * U(I,K)
C
            DO 260 K = L, N
               U(J,K) = U(J,K) + S * RV1(K)
  260    CONTINUE
C
  270    DO 280 K = L, N
  280    U(I,K) = SCALE * U(I,K)
C
  290    S1 = MAX(S1,ABS(W(I))+ABS(RV1(I)))
  300 CONTINUE
C     .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS ..........
      IF (.NOT. MATV) GO TO 410
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 400 II = 1, N
         I = N + 1 - II
         IF (I .EQ. N) GO TO 390
         IF (G .EQ. 0.0E0) GO TO 360
C
         DO 320 J = L, N
C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  320    V(J,I) = (U(I,J) / U(I,L)) / G
C
         DO 350 J = L, N
            S = 0.0E0
C
            DO 340 K = L, N
  340       S = S + U(I,K) * V(K,J)
C
            DO 350 K = L, N
               V(K,J) = V(K,J) + S * V(K,I)
  350    CONTINUE
C
  360    DO 380 J = L, N
            V(I,J) = 0.0E0
            V(J,I) = 0.0E0
  380    CONTINUE
C
  390    V(I,I) = 1.0E0
         G = RV1(I)
         L = I
  400 CONTINUE
C     .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS ..........
  410 IF (.NOT. MATU) GO TO 510
C     ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- ..........
      MN = N
      IF (M .LT. N) MN = M
C
      DO 500 II = 1, MN
         I = MN + 1 - II
         L = I + 1
         G = W(I)
         IF (I .EQ. N) GO TO 430
C
         DO 420 J = L, N
  420    U(I,J) = 0.0E0
C
  430    IF (G .EQ. 0.0E0) GO TO 475
         IF (I .EQ. MN) GO TO 460
C
         DO 450 J = L, N
            S = 0.0E0
C
            DO 440 K = L, M
  440       S = S + U(K,I) * U(K,J)
C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
            F = (S / U(I,I)) / G
C
            DO 450 K = I, M
               U(K,J) = U(K,J) + F * U(K,I)
  450    CONTINUE
C
  460    DO 470 J = I, M
  470    U(J,I) = U(J,I) / G
C
         GO TO 490
C
  475    DO 480 J = I, M
  480    U(J,I) = 0.0E0
C
  490    U(I,I) = U(I,I) + 1.0E0
  500 CONTINUE
C     .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
  510 CONTINUE
C     .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
      DO 700 KK = 1, N
         K1 = N - KK
         K = K1 + 1
         ITS = 0
C     .......... TEST FOR SPLITTING.
C                FOR L=K STEP -1 UNTIL 1 DO -- ..........
  520    DO 530 LL = 1, K
            L1 = K - LL
            L = L1 + 1
            IF (S1 + ABS(RV1(L)) .EQ. S1) GO TO 565
C     .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
            IF (S1 + ABS(W(L1)) .EQ. S1) GO TO 540
  530    CONTINUE
C     .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
  540    C = 0.0E0
         S = 1.0E0
C
         DO 560 I = L, K
            F = S * RV1(I)
            RV1(I) = C * RV1(I)
            IF (S1 + ABS(F) .EQ. S1) GO TO 565
            G = W(I)
            H = PYTHAG(F,G)
            W(I) = H
            C = G / H
            S = -F / H
            IF (.NOT. MATU) GO TO 560
C
            DO 550 J = 1, M
               Y = U(J,L1)
               Z = U(J,I)
               U(J,L1) = Y * C + Z * S
               U(J,I) = -Y * S + Z * C
  550       CONTINUE
C
  560    CONTINUE
C     .......... TEST FOR CONVERGENCE ..........
  565    Z = W(K)
         IF (L .EQ. K) GO TO 650
C     .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
         IF (ITS .EQ. 30) GO TO 1000
         ITS = ITS + 1
         X = W(L)
         Y = W(K1)
         G = RV1(K1)
         H = RV1(K)
         F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
         G = PYTHAG(F,1.0E0)
         F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H)
C     .......... NEXT QR TRANSFORMATION ..........
         C = 1.0E0
         S = 1.0E0
C
         DO 600 I1 = L, K1
            I = I1 + 1
            G = RV1(I)
            Y = W(I)
            H = S * G
            G = C * G
            Z = PYTHAG(F,H)
            RV1(I1) = Z
            C = F / Z
            S = H / Z
            F = X * C + G * S
            G = -X * S + G * C
            H = Y * S
            Y = Y * C
            IF (.NOT. MATV) GO TO 575
C
            DO 570 J = 1, N
               X = V(J,I1)
               Z = V(J,I)
               V(J,I1) = X * C + Z * S
               V(J,I) = -X * S + Z * C
  570       CONTINUE
C
  575       Z = PYTHAG(F,H)
            W(I1) = Z
C     .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
            IF (Z .EQ. 0.0E0) GO TO 580
            C = F / Z
            S = H / Z
  580       F = C * G + S * Y
            X = -S * G + C * Y
            IF (.NOT. MATU) GO TO 600
C
            DO 590 J = 1, M
               Y = U(J,I1)
               Z = U(J,I)
               U(J,I1) = Y * C + Z * S
               U(J,I) = -Y * S + Z * C
  590       CONTINUE
C
  600    CONTINUE
C
         RV1(L) = 0.0E0
         RV1(K) = F
         W(K) = X
         GO TO 520
C     .......... CONVERGENCE ..........
  650    IF (Z .GE. 0.0E0) GO TO 700
C     .......... W(K) IS MADE NON-NEGATIVE ..........
         W(K) = -Z
         IF (.NOT. MATV) GO TO 700
C
         DO 690 J = 1, N
  690    V(J,K) = -V(J,K)
C
  700 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO A
C                SINGULAR VALUE AFTER 30 ITERATIONS ..........
 1000 IERR = K
 1001 RETURN
      END