SUBROUTINE DfDx_1D_Uneven(f,nx,coeffs,rank,fx)
!
! A subroutine to take the first derivative of the function f on an
! arbitrary grid with one-sided derivatives towards the two boundaries
! using the coefficients coeffs(1:rank,2,1:nx).  The coefficients are
! computed in BuildStencil_1D_Uneven.
!
! By Allan P. Engsig-Karup.
  USE Precision
  IMPLICIT NONE
  INTEGER nx, i, rank, alpha
  REAL(kind=long) :: f(nx), coeffs(rank,rank,nx), fx(nx)

  alpha=(rank-1)/2

  ! One-sided derivatives towards the left end
  do i=1,alpha
     fx(i)=Dot_Product(f(1:rank),coeffs(1:rank,2,i))
  end do
  ! Centered schemes for the interior
  do i=alpha+1,Nx-alpha
     fx(i)=Dot_Product(f(i-alpha:i+alpha),coeffs(1:rank,2,i))
  end do
  ! One-sided derivatives towards the right end
  do i=Nx-alpha+1,Nx
     fx(i)=Dot_Product(f(Nx-rank+1:Nx),coeffs(1:rank,2,i))
  end do

  RETURN
END SUBROUTINE DfDx_1D_Uneven


      FUNCTION rofunc(b)
      INTEGER NMAX
      REAL rofunc,b,EPS
      PARAMETER (NMAX=1000,EPS=1.e-7)
CU    USES select
      INTEGER j,ndata
      REAL aa,abdev,d,sum,arr(NMAX),x(NMAX),y(NMAX),select
      COMMON /arrays/ x,y,arr,aa,abdev,ndata
      do 11 j=1,ndata
        arr(j)=y(j)-b*x(j)
11    continue
      if (mod(ndata,2).eq.0) then
        j=ndata/2
        aa=0.5*(select(j,ndata,arr)+select(j+1,ndata,arr))
      else
        aa=select((ndata+1)/2,ndata,arr)
      endif
      sum=0.
      abdev=0.
      do 12 j=1,ndata
        d=y(j)-(b*x(j)+aa)
        abdev=abdev+abs(d)
        if (y(j).ne.0.) d=d/abs(y(j))
        if (abs(d).gt.EPS) sum=sum+x(j)*sign(1.0,d)
12    continue
      rofunc=sum
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rofunc.for


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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
!     shpgi and shpg.
!
submodule(scalar_projection_routines) scalar_projection_gaussian_grid

contains
    !
    ! Purpose:
    !
    !     shpg computes the harmonic projection, which is
    !     equivalent to a harmonic analysis (forward) followed
    !     by a harmonic synthesis (backward transform).
    !     shpg uses the n**2 projection or complement when appropriate
    !     as well as  odd/even factorization and zero truncation on an
    !     on a Gaussian distributed grid as defined in the JCP paper
    !     "Generalized discrete spherical harmonic transforms"
    !     by Paul N. Swarztrauber and William F. Spotz
    !     J. Comp. Phys., 159(2000) pp. 213-230.
    !
    !     subroutine shpg(nlat, nlon, isym, mtrunc, x, y, idxy, wshp, lwshp, iwshp, liwshp, work, lwork, ierror)
    !
    !     shpg 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 be at 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 shpg. It must be
    !            at least nlat.
    !
    !     wshp   a single precision array that must be saved for
    !            repeated use by subroutine shpg.
    !
    !     lwshp  the dimension of the array wshp as it appears in the
    !            program that calls shpgi. 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 shpg.
    !
    !
    !     liwshp the dimension of the array iwshp as it appears in the
    !            program that calls shpgi. 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 shpg. 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 shpg(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, nte
        integer(ip) :: nloc2
        type(SpherepackUtility) :: util

        ! Check calling arguments
        ierror = 1
        if (nlat < 1) return
        ierror = 2
        if (nlon < 1) 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**2)
        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 shpg_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 shpg

    ! Purpose:
    !
    !     shpgi initializes the arrays wshp and iwshp for subsequent
    !     use in subroutine shpg, which performs the harmonic projection
    !     which is equivalent to a harmonic analysis followed by
    !     harmonic synthesis but faster and with less memory.
    !     (see description of subroutine shpg below).
    !
    !     subroutine shpgi(nlat, nlon, isym, mtrunc, wshp, lwshp, iwshp, liwshp, work, lwork, ierror)
    !
    !     shpgi initializes arrays wshp and iwshp for repeated use
    !     by subroutine shpg ....
    !
    !     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 be at least 4.
    !
    !     isym   currently not used, no equatorial symmetries assumed,
    !            only whole sphere computations.
    !
    !     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 shpgi. 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 shpgi. It must be at least
    !            4*(nlat + 1).
    !
    !     lwork  the dimension of the array work as it appears in the
    !            program that calls shpgi. 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 shpg.
    !
    !     iwshp  an integer array that must be saved for repeated
    !            use by subroutine shpg.
    !
    !     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 shpgi(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) :: ktot
        integer(ip) :: kw1
        integer(ip) :: kw10
        integer(ip) :: kw11
        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

        ! Check calling arguments
        ierror = 1
        if (nlat<1) return
        ierror = 2
        if (nlon<1) 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
        lw1 = 2*((nlat + 1)**2)
        log2n = int(log(real(nlon, kind=wp))/log(TWO), kind=ip)
        if (lwshp<lw1+nlon+log2n) return
        ierror = 6
        if (liwshp<4*(nlat + 1)) return
        ierror = 7
        mlwk = (5*((nlat + 1)**2+7*nlat+8))/4
        if (lwork <mlwk) return
        ierror = 0

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

        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+2*nte
        kw5 = kw4+2*nte
        kw6 = kw5+nte
        kw7 = kw6+nte
        kw8 = kw7+4*nte
        kw9 = kw8+2*nte
        kw10 = kw9+nloc1
        kw11 = kw10+nloc1
        ktot = kw11+nte*nte

        call shpgi_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))

    end subroutine shpgi

    subroutine shpgi_lower_utility_routine(nlat, nlon, isym, mtrunc, idp, ierror, &
        pe, po, ze, zo, ipse, jzse, ipso, jzso, &
        cp, wx, thet, gwts, xx, z, a, b, ped, pod, u)

        real(wp) :: dfn
        real(wp) :: dmax
        integer(ip) :: i
        integer(ip) :: idp
        integer(ip) :: ierr
        integer(ip) :: ierror
        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) :: ms2
        integer(ip) :: mtrunc
        integer(ip) :: mxtr
        integer(ip) :: n
        integer(ip) :: nec
        integer(ip) :: nem
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nmx
        integer(ip) :: noc
        integer(ip) :: nom
        integer(ip) :: ns2
        integer(ip) :: nshe
        integer(ip) :: nsho
        integer(ip) :: nte
        integer(ip) :: nto
        real(wp) :: pe
        real(wp) :: po
        real(wp) :: sum1
        real(wp) :: toe
        real(wp) :: tusl
        real(wp) :: ze
        real(wp) :: zo
        real(wp) :: zort

        real(wp) :: summation, a1, b1, c1
        real(wp) :: cp(idp), wx(idp), &
            thet(nlat), gwts(nlat), xx(idp), z(idp), a(4*idp), &
            b(2*idp), ped(idp, idp, 2), pod(idp, idp, 2), u(idp, idp)

        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)
        dimension zort(64, 64, 2)

        type(SpherepackUtility) :: util

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

        ! Compute gauss grid distribution
        call compute_gaussian_latitudes_and_weights(nlat, thet, gwts, ierr)

        gwts(1:nto) = TWO * gwts(1:nto)

        ! Compute n**2 basis (even functions)
        do n=1, 2*nlat-2
            dfn = n
            a(n) = sqrt(dfn * (dfn + ONE))
        end do

        do n=1, nlat-1
            dfn = n
            b(n) = sqrt((TWO * dfn + THREE)/(TWO * dfn - ONE))
        end do

        mxtr = min(nlat-1, nlon/2, mtrunc)
        iip = 2
        generate_even_functions: do mp1=1, mxtr+1
            m = mp1-1
            iip = 3-iip
            ms2 = mp1/2
            nem = (nlat-m+1)/2
            nec = nte-nem

            ! 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+nec, iip))
                    end do
                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+nec) = ped(i, j+nec, 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+nec) = a1*ped(i, j+nec-1, iip) &
                                    - b1*ped(i, j+nec, iip)
                            end do
                        else
                            c1 = b(n-1)*a(n-m-1)/a(n+m-1)
                            do i=1, nte
                                u(i, j+nec) = a1*ped(i, j+nec-1, iip) &
                                    - b1*ped(i, j+nec, iip) + c1*u(i, j+nec-1)
                            end do
                        end if
                    end if
                end do
                do j=1, nem
                    do i=1, nte
                        ped(i, j+nec, iip) = u(i, j+nec)
                    end do
                end do
            end if
            if (nec<=0) cycle generate_even_functions
            !
            !     generate orthogonal vector with
            !     random numbers
            call random_seed()
            call random_number(xx(1:nte))

            it = 0
            generate_random_orth_vec_even: do
                it = it+1
                if (it > 2) exit generate_random_orth_vec_even

                do i=1, nte
                    z(i) = ZERO
                    wx(i) = gwts(i)*xx(i)
                end do

                do j=1, nte
                    if (j == nec) 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 calculate_normal(nte, xx, idp, gwts)

            end do generate_random_orth_vec_even

            do i=1, nte
                ped(i, nec, iip) = xx(i)
            end do
        end do generate_even_functions
        !
        !     reorder if mtrunc is less than nlat-1
        !         case of even functions
        !
        nmx = nlat-mxtr
        if (modn==1) then
            nshe(1) = nmx/2
            nshe(2) = (nmx-1)/2
        else
            nshe(1) = (nmx-1)/2
            nshe(2) = nmx/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 = ped(j, i, iip)*gwts(j)
                    ze(j, i, iip) =  summation
                    pe(i, j, iip) = ped(i, j, iip)
                    if (abs(summation)>MACHINE_EPSILON .and. lock==0) then
                        lock = 1
                        jzse(i, iip) = j
                    end if
                end do
            end do
        end do
        !
        !     check orthogonality of pe(i, j, mp1)  mp1=1, 2
        !
        do iip=1, 2
            dmax = ZERO
            do i=1, nte
                do j=1, nte
                    sum1 = ZERO
                    do k=1, nte
                        sum1 = sum1+ze(k, i, iip)*pe(k, j, iip)
                    end do
                    zo(i, j, iip) = sum1
                    if (i/=j) then
                        dmax = max(dmax, abs(sum1))
                    else
                        dmax = max(dmax, abs(sum1-ONE))
                    end if
                end do
            end do
        end do
        !
        ! Compute n**2 basis (odd functions)
        !
        iip = 2
        generate_odd_functions: do mp1=1, mxtr+1
            iip = 3-iip
            m = mp1-1
            ms2 = mp1/2
            nem = (nlat-m+1)/2
            nom = nlat-m-nem
            noc = nto-nom
            !
            ! 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+noc, iip))
                    end do
                    if (modn>0) pod(nte, j+noc, 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+noc) = pod(i, j+noc, 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+noc) = a1*pod(i, j+noc-1, iip) &
                                    - b1*pod(i, j+noc, iip)
                            end do
                        else
                            c1 = b(n-1)*a(n-m-1)/a(n+m-1)
                            do i=1, nte
                                u(i, j+noc) = a1*pod(i, j+noc-1, iip) &
                                    - b1*pod(i, j+noc, iip) + c1*u(i, j+noc-1)
                            end do
                        end if
                    end if
                    if (modn==1) u(nte, j+noc) = ZERO
                end do
                do j=1, nom
                    do i=1, nte
                        pod(i, j+noc, iip) = u(i, j+noc)
                    end do
                end do
            end if

            if (noc <= 0) cycle generate_odd_functions

            call random_number(xx(1:nte))

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

            it = 0
            generate_random_orth_vec_odd: do
                it = it+1
                if (it > 2) exit generate_random_orth_vec_odd

                z(1: nte) = ZERO
                wx(1: nte) = gwts(1: nte)*xx(1: nte)

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

                xx(1: nte) = xx(1: nte)-z(1: nte)

                call calculate_normal(nte, xx, idp, gwts)
            end do generate_random_orth_vec_odd

            pod(1: nte, noc, iip) = xx(1: nte)

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

        nmx = nlat-mxtr

        if (modn==1) then
            nsho(1) = (nmx-1)/2
            nsho(2) = nmx/2
        else
            nsho(1) = nmx/2
            nsho(2) = (nmx-1)/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 = pod(j, i, iip)*gwts(j)
                    zo(j, i, iip) = summation
                    po(i, j, iip) = pod(i, j, iip)
                    if (abs(summation)>MACHINE_EPSILON .and. lock==0) then
                        lock = 1
                        jzso(i, iip) = j
                    end if
                end do
            end do
        end do
        !
        !     check orthogonality of po(i, j, mp1)  mp1=1, 2
        !
        do iip=1, 2
            dmax = ZERO
            do i=1, nto
                do j=1, nto
                    sum1 = ZERO
                    do k=1, nto
                        sum1 = sum1+zo(k, i, iip)*po(k, j, iip)
                    end do
                    zort(i, j, iip) = sum1
                    if (i/=j) then
                        dmax = max(dmax, abs(sum1))
                    else
                        dmax = max(dmax, abs(sum1-ONE))
                    end if
                end do
            end do
        end do

    end subroutine shpgi_lower_utility_routine

    subroutine shpg_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) :: lag
        integer(ip) :: m
        integer(ip) :: modn
        integer(ip) :: mp1
        integer(ip) :: mpm
        integer(ip) :: ms2
        integer(ip) :: mtrunc
        integer(ip) :: mxtr
        integer(ip) :: nec
        integer(ip) :: nem
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nmx
        integer(ip) :: noc
        integer(ip) :: nom
        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
        !
        mxtr = min(nlat-1, nlon/2, mtrunc)
        nmx = nlat-mxtr
        if (modn==1) then
            nshe(1) = nmx/2
            nshe(2) = (nmx-1)/2
            nsho(1) = (nmx-1)/2
            nsho(2) = nmx/2
        else
            nshe(1) = (nmx-1)/2
            nshe(2) = nmx/2
            nsho(1) = nmx/2
            nsho(2) = (nmx-1)/2
        end if
        !
        iip = 2
        outer_loop: do mp1=1, mxtr+1
            iip = 3-iip
            if (mxtr==nlat-1 .and. mp1==1) then
                do i=1, nlat
                    sy(i, mp1) = sx(i, mp1)
                end do
                cycle outer_loop
            end if
            m = mp1-1
            mpm = max(1, m+m)
            ms2 = mp1/2
            nem = (nlat-m+1)/2-nshe(iip)
            nom = (nlat-m)/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

            lag = 0
            if (m==0.or.mpm==nlon) lag = 1
            if (3*nec<2*nem.or.nem==0) then
                call matrix_multiply(lag, 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_multiply(lag, 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_multiply(lag, nto, noc, idp, po(1, 1, iip), nto, idp, &
                    zo(1, 1, iip), xo, yo, ipso(1, iip), jzso(1, iip))
                do i=1, nto
                    yo(i, 1) = xo(i, 1)-yo(i, 1)
                end do
                if (mpm<nlon .and. m/=0) then
                    do i=1, nto
                        yo(i, 2) = xo(i, 2)-yo(i, 2)
                    end do
                end if
            else
                call matrix_multiply(lag, 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, nto
                sy(i, mpm) = ye(i, 1)+yo(i, 1)
                sy(nlat+1-i, mpm) = ye(i, 1)-yo(i, 1)
            end do
            if (nte>nto) sy(nte, mpm) = ye(nte, 1)
            if (mpm<nlon .and. m/=0) then
                do i=1, nto
                    sy(i, mpm+1) = ye(i, 2)+yo(i, 2)
                    sy(nlat+1-i, mpm+1) = ye(i, 2)-yo(i, 2)
                end do
                if (nte>nto) sy(nte, mpm+1) = ye(nte, 2)
            end if
        end do outer_loop

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

    end subroutine shpg_lower_utility_routine

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

        ! Dummy arguments
        integer(ip), intent(in)  :: lag
        integer(ip), intent(in)  :: lc
        integer(ip), intent(in)  :: ld
        integer(ip), intent(in)  :: lr
        real(wp),    intent(in)  :: a(ld, *)
        integer(ip), intent(in)  :: mc
        integer(ip), intent(in)  :: md
        real(wp),    intent(in)  :: b(md, *)
        real(wp),    intent(in)  :: x(ld, 2)
        real(wp),    intent(inout) :: y(ld, 2)
        integer(ip), intent(in)  :: is(*)
        integer(ip), intent(in)  :: js(*)

        ! Local variables
        integer(ip) :: i, j, k, kmx
        real(wp)    :: sum1, sum2

        kmx = min(lr+1, ld)

        select case (lag)
            case(1)
                y(1: kmx, 1) = ZERO
                if (lc > 0) then
                    do i=1, lc
                        sum1 = ZERO
                        do j=js(i), mc
                            sum1 = sum1 + b(j, i)*x(j, 1)
                        end do
                        do k=is(i), lr
                            y(k, 1) = y(k, 1)+sum1*a(k, i)
                        end do
                    end do
                end if
            case default
                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 select

    end subroutine matrix_multiply

    subroutine calculate_normal(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(n)

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

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

        x = x/sqrt(sqs)

    end subroutine calculate_normal

end submodule scalar_projection_gaussian_grid


module analriem_module

  contains

    subroutine analriem(ilo,ihi,gamma,pl,rl,ul,pr,rr,ur,smallp,pstar,ustar)

      use amrex_fort_module, only : rt => amrex_real
      implicit none

      integer, intent(in) :: ilo, ihi

      real(rt), intent(in ), dimension(ilo:ihi) :: pl,rl,ul,pr,rr,ur
      real(rt), intent(in ) :: gamma, smallp
      real(rt), intent(out), dimension(ilo:ihi) :: pstar,ustar

      ! Local variables
      real(rt), dimension(ilo:ihi) :: pstnm1,ustarp,ustarm
      real(rt), dimension(ilo:ihi) :: wl,wr,wlsq,wrsq
      real(rt), dimension(ilo:ihi) :: cleft,cright
      real(rt), dimension(ilo:ihi) :: dpditer,zp,zm,denom
      real(rt), dimension(ilo:ihi) :: ustnm1,ustnp1
      integer          :: iter

      real(rt), parameter :: weakwv = 1.d-3
      real(rt), parameter :: small  = 1.d-6

      integer :: i

      wl = sqrt(gamma*pl*rl)
      wr = sqrt(gamma*pr*rr)

      cleft  = wl/rl
      cright = wr/rr

      pstar=(wl*pr+wr*pl-wr*wl*(ur-ul))/(wl+wr)

      pstar=max(pstar,smallp)
      pstnm1 = pstar

      wlsq = (.5d0*(gamma-1.d0)*(pstar+pl)+pstar) * rl
      wrsq = (.5d0*(gamma-1.d0)*(pstar+pr)+pstar) * rr

      wl = sqrt(wlsq)
      wr = sqrt(wrsq)

      ustarp = ul - (pstar-pl)/wl
      ustarm = ur + (pstar-pr)/wr

      pstar = (wl*pr+wr*pl-wr*wl*(ur-ul))/(wl+wr)

      pstar=max(pstar,smallp)

      do iter = 1,3

        wlsq = (.5d0*(gamma-1.d0)*(pstar+pl)+pstar) * rl
        wrsq = (.5d0*(gamma-1.d0)*(pstar+pr)+pstar) * rr

        wl = 1.d0/sqrt(wlsq)
        wr = 1.d0/sqrt(wrsq)

        ustnm1 = ustarm
        ustnp1 = ustarp

        ustarm = ur - (pr-pstar)*wr
        ustarp = ul + (pl-pstar)*wl

        dpditer = abs(pstnm1-pstar)
        zp      = abs(ustarp-ustnp1)

        do i = ilo, ihi
          if (zp(i)-weakwv*cleft(i) .lt. 0.0d0 ) then
            zp(i) = dpditer(i)*wl(i)
          endif
        end do

        zm=abs(ustarm-ustnm1)

        do i = ilo, ihi
          if (zm(i)-weakwv*cright(i) .lt. 0.0d0 ) then
            zm(i) = dpditer(i)*wr(i)
          endif
        end do

        denom  = dpditer/max(zp+zm,small*(cleft+cright))
        pstnm1 = pstar

        pstar = pstar - denom*(ustarm-ustarp)

        pstar = max(pstar,smallp)

        ustar = 0.5d0*(ustarm+ustarp)

     end do

    end subroutine analriem

  end module analriem_module


*DECK HWSCSP
      SUBROUTINE HWSCSP (INTL, TS, TF, M, MBDCND, BDTS, BDTF, RS, RF, N,
     +   NBDCND, BDRS, BDRF, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HWSCSP
C***PURPOSE  Solve a finite difference approximation to the modified
C            Helmholtz equation in spherical coordinates assuming
C            axisymmetry  (no dependence on longitude).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HWSCSP-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HWSCSP solves a finite difference approximation to the
C       modified Helmholtz equation in spherical coordinates assuming
C       axisymmetry  (no dependence on longitude)
C
C          (1/R**2)(d/dR)((R**2)(d/dR)U)
C
C             + (1/(R**2)SIN(THETA))(d/dTHETA)(SIN(THETA)(d/dTHETA)U)
C
C             + (LAMBDA/(RSIN(THETA))**2)U = F(THETA,R).
C
C     This two dimensional modified Helmholtz equation results from
C     the Fourier transform of the three dimensional Poisson equation
C
C     * * * * * * * * * *     On Input     * * * * * * * * * *
C
C     INTL
C       = 0  On initial entry to HWSCSP or if any of the arguments
C            RS, RF, N, NBDCND are changed from a previous call.
C       = 1  If RS, RF, N, NBDCND are all unchanged from previous call
C            to HWSCSP.
C
C       NOTE   A call with INTL=0 takes approximately 1.5 times as
C              much time as a call with INTL = 1.  Once a call with
C              INTL = 0 has been made then subsequent solutions
C              corresponding to different F, BDTS, BDTF, BDRS, BDRF can
C              be obtained faster with INTL = 1 since initialization is
C              not repeated.
C
C     TS,TF
C       The range of THETA (colatitude), i.e., TS .LE. THETA .LE. TF.
C       TS must be less than TF.  TS and TF are in radians.  A TS of
C       zero corresponds to the north pole and a TF of PI corresponds
C       to the south pole.
C
C     * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * *
C
C     If TF is equal to PI then it must be computed using the statement
C     TF = PIMACH(DUM). This insures that TF in the users program is
C     equal to PI in this program which permits several tests of the
C     input parameters that otherwise would not be possible.
C
C     M
C       The number of panels into which the interval (TS,TF) is
C       subdivided.  Hence, there will be M+1 grid points in the
C       THETA-direction given by THETA(K) = (I-1)DTHETA+TS for
C       I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width.
C
C     MBDCND
C       Indicates the type of boundary condition at THETA = TS and
C       THETA = TF.
C
C       = 1  If the solution is specified at THETA = TS and THETA = TF.
C       = 2  If the solution is specified at THETA = TS and the
C            derivative of the solution with respect to THETA is
C            specified at THETA = TF (see note 2 below).
C       = 3  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS and THETA = TF (see notes 1,2
C            below).
C       = 4  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS (see note 1 below) and the
C            solution is specified at THETA = TF.
C       = 5  If the solution is unspecified at THETA = TS = 0 and the
C            solution is specified at THETA = TF.
C       = 6  If the solution is unspecified at THETA = TS = 0 and the
C            derivative of the solution with respect to THETA is
C            specified at THETA = TF (see note 2 below).
C       = 7  If the solution is specified at THETA = TS and the
C            solution is unspecified at THETA = TF = PI.
C       = 8  If the derivative of the solution with respect to THETA is
C            specified at THETA = TS (see note 1 below) and the solution
C            is unspecified at THETA = TF = PI.
C       = 9  If the solution is unspecified at THETA = TS = 0 and
C            THETA = TF = PI.
C
C       NOTES:  1.  If TS = 0, do not use MBDCND = 3,4, or 8, but
C                   instead use MBDCND = 5,6, or 9  .
C               2.  If TF = PI, do not use MBDCND = 2,3, or 6, but
C                   instead use MBDCND = 7,8, or 9  .
C
C     BDTS
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = TS.  When MBDCND = 3,4, or 8,
C
C            BDTS(J) = (d/dTHETA)U(TS,R(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDTS is a dummy variable.
C
C     BDTF
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = TF.  When MBDCND = 2,3, or 6,
C
C            BDTF(J) = (d/dTHETA)U(TF,R(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDTF is a dummy variable.
C
C     RS,RF
C       The range of R, i.e., RS .LE. R .LT. RF.  RS must be less than
C       RF.  RS must be non-negative.
C
C       N
C       The number of panels into which the interval (RS,RF) is
C       subdivided.  Hence, there will be N+1 grid points in the
C       R-direction given by R(J) = (J-1)DR+RS for J = 1,2,...,N+1,
C       where DR = (RF-RS)/N is the panel width.
C       N must be greater than 2
C
C     NBDCND
C       Indicates the type of boundary condition at R = RS and R = RF.
C
C       = 1  If the solution is specified at R = RS and R = RF.
C       = 2  If the solution is specified at R = RS and the derivative
C            of the solution with respect to R is specified at R = RF.
C       = 3  If the derivative of the solution with respect to R is
C            specified at R = RS and R = RF.
C       = 4  If the derivative of the solution with respect to R is
C            specified at RS and the solution is specified at R = RF.
C       = 5  If the solution is unspecified at R = RS = 0 (see note
C            below) and the solution is specified at R = RF.
C       = 6  If the solution is unspecified at R = RS = 0 (see note
C            below) and the derivative of the solution with respect to
C            R is specified at R = RF.
C
C       NOTE:  NBDCND = 5 or 6 cannot be used with
C              MBDCND = 1,2,4,5, or 7 (the former indicates that the
C                       solution is unspecified at R = 0, the latter
C                       indicates that the solution is specified).
C                       Use instead
C              NBDCND = 1 or 2  .
C
C     BDRS
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to R at R = RS.
C       When NBDCND = 3 or 4,
C
C            BDRS(I) = (d/dR)U(THETA(I),RS), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDRS is a dummy variable.
C
C     BDRF
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to R at R = RF.
C       When NBDCND = 2,3, or 6,
C
C            BDRF(I) = (d/dR)U(THETA(I),RF), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDRF is a dummy variable.
C
C     ELMBDA
C       The constant LAMBDA in the Helmholtz equation.  If
C       LAMBDA .GT. 0, a solution may not exist.  However, HWSCSP will
C       attempt to find a solution.  If NBDCND = 5 or 6 or
C       MBDCND = 5,6,7,8, or 9, ELMBDA must be zero.
C
C     F
C       A two-dimensional array that specifies the value of the right
C       side of the Helmholtz equation and boundary values (if any).
C       for I = 2,3,...,M and J = 2,3,...,N
C
C            F(I,J) = F(THETA(I),R(J)).
C
C       On the boundaries F is defined by
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   ----------        ----------
C
C              1      U(TS,R(J))        U(TF,R(J))
C              2      U(TS,R(J))        F(TF,R(J))
C              3      F(TS,R(J))        F(TF,R(J))
C              4      F(TS,R(J))        U(TF,R(J))
C              5      F(0,R(J))         U(TF,R(J))   J = 1,2,...,N+1
C              6      F(0,R(J))         F(TF,R(J))
C              7      U(TS,R(J))        F(PI,R(J))
C              8      F(TS,R(J))        F(PI,R(J))
C              9      F(0,R(J))         F(PI,R(J))
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   --------------    --------------
C
C              1      U(THETA(I),RS)    U(THETA(I),RF)
C              2      U(THETA(I),RS)    F(THETA(I),RF)
C              3      F(THETA(I),RS)    F(THETA(I),RF)
C              4      F(THETA(I),RS)    U(THETA(I),RF)   I = 1,2,...,M+1
C              5      F(TS,0)           U(THETA(I),RF)
C              6      F(TS,0)           F(THETA(I),RF)
C
C       F must be dimensioned at least (M+1)*(N+1).
C
C       NOTE
C
C       If the table calls for both the solution U and the right side F
C       at a corner then the solution must be specified.
C
C     IDIMF
C       The row (or first) dimension of the array F as it appears in the
C       program calling HWSCSP.  This parameter is used to specify the
C       variable dimension of F.  IDIMF must be at least M+1  .
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space. Its length can be computed from the formula below
C       which depends on the value of NBDCND.
C
C       If NBDCND=2,4 or 6 define NUNK=N
C       If NBDCND=1 or 5   define NUNK=N-1
C       If NBDCND=3        define NUNK=N+1
C
C       Now set K=INT(log2(NUNK))+1 and L=2**(K+1) then W must be
C       dimensioned at least (K-2)*L+K+5*(M+N)+MAX(2*N,6*M)+23
C
C       **IMPORTANT** For purposes of checking, the required length
C                     of W is computed by HWSCSP and stored in W(1)
C                     in floating point format.
C
C
C     * * * * * * * * * *     On Output     * * * * * * * * * *
C
C     F
C       Contains the solution U(I,J) of the finite difference
C       approximation for the grid point (THETA(I),R(J)),
C       I = 1,2,...,M+1,   J = 1,2,...,N+1  .
C
C     PERTRB
C       If a combination of periodic or derivative boundary conditions
C       is specified for a Poisson equation (LAMBDA = 0), a solution may
C       not exist.  PERTRB is a constant, calculated and subtracted from
C       F, which ensures that a solution exists.  HWSCSP then computes
C       this solution, which is a least squares solution to the original
C       approximation. This solution is not unique and is unnormalized.
C       The value of PERTRB should be small compared to the right side
C       F. Otherwise , a solution is obtained to an essentially
C       different problem. This comparison should always be made to
C       insure that a meaningful solution has been obtained.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for numbers 0 and 10, a solution is not attempted.
C
C       = 1  TS.LT.0. or TF.GT.PI
C       = 2  TS.GE.TF
C       = 3  M.LT.5
C       = 4  MBDCND.LT.1 or MBDCND.GT.9
C       = 5  RS.LT.0
C       = 6  RS.GE.RF
C       = 7  N.LT.5
C       = 8  NBDCND.LT.1 or NBDCND.GT.6
C       = 9  ELMBDA.GT.0
C       = 10 IDIMF.LT.M+1
C       = 11 ELMBDA.NE.0 and MBDCND.GE.5
C       = 12 ELMBDA.NE.0 and NBDCND equals 5 or 6
C       = 13 MBDCND equals 5,6 or 9 and TS.NE.0
C       = 14 MBDCND.GE.7 and TF.NE.PI
C       = 15 TS.EQ.0 and MBDCND equals 3,4 or 8
C       = 16 TF.EQ.PI and MBDCND equals 2,3 or 6
C       = 17 NBDCND.GE.5 and RS.NE.0
C       = 18 NBDCND.GE.5 and MBDCND equals 1,2,4,5 or 7
C
C       Since this is the only means of indicating a possibly incorrect
C       call to HWSCSP, the user should test IERROR after a call.
C
C     W
C       Contains intermediate values that must not be destroyed if
C       HWSCSP will be called again with INTL = 1.  W(1) contains the
C       number of locations which W must have.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDTS(N+1),BDTF(N+1),BDRS(M+1),BDRF(M+1),
C     Arguments      F(IDIMF,N+1),W(see argument list)
C
C     Latest         June 1979
C     Revision
C
C     Subprograms    HWSCSP,HWSCS1,BLKTRI,BLKTR1,PROD,PRODP,CPROD,CPRODP
C     Required       ,COMBP,PPADD,PSGF,BSRH,PPSGF,PPSPF,TEVLS,INDXA,
C                    ,INDXB,INDXC,R1MACH
C
C     Special
C     Conditions
C
C     Common         CBLKT
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Paul N Swarztrauber
C
C     Language       FORTRAN
C
C     History        Version 1 September 1973
C                    Version 2 April     1976
C                    Version 3 June      1979
C
C     Algorithm      The routine defines the finite difference
C                    equations, incorporates boundary data, and adjusts
C                    the right side of singular systems and then calls
C                    BLKTRI to solve the system.
C
C     Space
C     Required
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine accuracy is set using function R1MACH.
C
C     Required       NONE
C     Resident
C     Routines
C
C     Reference      Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms for The Solution Of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 pp.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  HWSCS1, PIMACH
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HWSCSP
C
      DIMENSION       F(IDIMF,*) ,BDTS(*)    ,BDTF(*)    ,BDRS(*)    ,
     1                BDRF(*)    ,W(*)
C***FIRST EXECUTABLE STATEMENT  HWSCSP
      PI = PIMACH(DUM)
      IERROR = 0
      IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1
      IF (TS .GE. TF) IERROR = 2
      IF (M .LT. 5) IERROR = 3
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 4
      IF (RS .LT. 0.) IERROR = 5
      IF (RS .GE. RF) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 8
      IF (ELMBDA .GT. 0.) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 11
      IF (ELMBDA.NE.0. .AND. (NBDCND.EQ.5 .OR. NBDCND.EQ.6)) IERROR = 12
      IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND.
     1    TS.NE.0.) IERROR = 13
      IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 14
      IF (TS.EQ.0. .AND.
     1    (MBDCND.EQ.4 .OR. MBDCND.EQ.8 .OR. MBDCND.EQ.3)) IERROR = 15
      IF (TF.EQ.PI .AND.
     1    (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 16
      IF (NBDCND.GE.5 .AND. RS.NE.0.) IERROR = 17
      IF (NBDCND.GE.5 .AND. (MBDCND.EQ.1 .OR. MBDCND.EQ.2 .OR.
     1                                    MBDCND.EQ.5 .OR. MBDCND.EQ.7))
     2    IERROR = 18
      IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN
      NCK = N
      GO TO (101,103,102,103,101,103),NBDCND
  101 NCK = NCK-1
      GO TO 103
  102 NCK = NCK+1
  103 L = 2
      K = 1
  104 L = L+L
      K = K+1
      IF (NCK-L) 105,105,104
  105 L = L+L
      NP1 = N+1
      MP1 = M+1
      I1 = (K-2)*L+K+MAX(2*N,6*M)+13
      I2 = I1+NP1
      I3 = I2+NP1
      I4 = I3+NP1
      I5 = I4+NP1
      I6 = I5+NP1
      I7 = I6+MP1
      I8 = I7+MP1
      I9 = I8+MP1
      I10 = I9+MP1
      W(1) = I10+M
      CALL HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS,
     1             BDRF,ELMBDA,F,IDIMF,PERTRB,W(2),W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10))
      RETURN
      END


      real(kind(0.0d0)) function pythag (a, b)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      real(double) , intent(in) :: a
      real(double) , intent(in) :: b
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      real(double) :: p, r, s, t, u
!-----------------------------------------------
!
!     finds dsqrt(a**2+b**2) without overflow or destructive underflow
!
      p = dmax1(dabs(a),dabs(b))
      if (p /= 0.0D0) then
         r = (dmin1(dabs(a),dabs(b))/p)**2
         t = 4.0D0 + r
         do while(t /= 4.0D0)
            s = r/t
            u = 1.0D0 + 2.0D0*s
            p = u*p
            r = (s/u)**2*r
            t = 4.0D0 + r
         end do
         go to 20
      endif
   20 continue
      pythag = p
      return
      end function pythag


program test6_reverse

  use multigrid

  implicit none

  integer, parameter :: num=selected_real_kind(p=15)
  real(num) :: pi = 4.0_num * ATAN(1.0_num)
  real(num) :: pi2 = 8.0_num * ATAN(1.0_num)

  integer :: nx, ny, ix, iy

  real(num) :: dx, dy, L2, x_min, x_max, y_min, y_max

  real(num), dimension(:), allocatable :: xc, yc
  real(num), dimension(:,:), allocatable :: f,analytic, phi
  real(num), dimension(:), allocatable :: L2_arr, n_arr

  real(num) :: x, y, A, B, k, C1, C2

  integer :: power, power_min, power_max

  type(mg_input) :: input

  ! setup a test problem

  A = 1.0_num
  B = 1.0_num
  k = 4.0_num

  print *,'Test6: Lphi= A * sin(k * 2pi *x)'
  print *,'x_min = fixed = B = ',B
  print *,'x_max = zerograd'
  print *,'2D => 1D via ybcs = periodic'
  print *,'also can test variable nx for convergence properties'

  power_min = 5
  power_max = 9

  allocate(L2_arr(1:1+power_max-power_min))
  allocate(n_arr(1:1+power_max-power_min))
  L2_arr = 1e6_num
  n_arr = 0

  different_resolutions: do power= power_min, power_max

    nx = 2**power
    ny = nx
    x_min = 0.0_num
    x_max = 1.0_num ! dont change these, I've hardcoded len = 1
    y_min = x_min
    y_max = x_max

    allocate(xc(-1:nx+2))
    allocate(yc(-1:ny+2))

    dx = (x_max - x_min) / real(nx,num)
    xc(-1) = x_min - 3.0_num * dx / 2.0_num
    do ix = 0,nx+2
      xc(ix) = xc(ix-1) + dx
    enddo

    dy = (y_max - y_min) / real(ny,num)
    yc(-1) = y_min - 3.0_num * dy / 2.0_num
    do iy = 0,ny+2
      yc(iy) = yc(iy-1) + dy
    enddo

    allocate(phi(-1:nx+2,-1:ny+2)) ! again, redundant ghosts but for comparison to CCAPS
    phi = 0.0_num

    allocate(analytic(1:nx,1:ny)) ! again, redundant ghosts but for comparison to CCAPS
    analytic = 0.0_num

    allocate(f(1:nx,1:ny))

    do iy = 1, ny
    do ix = 1, nx
      x = xc(ix)
      y = yc(iy)
      f(ix,iy) = A * sin(k * pi2 * x)
    enddo
    enddo

 ! Solve for phi

  input = mg_input(tol = 1e-12_num, nx=nx, ny = ny, dx=dx, dy=dy, f = f, phi = phi, &
            & bc_xmin = 'fixed', bc_xmax = 'zero_gradient', phi_bc_xmin = 1.0_num, &
            & bc_ymin = 'periodic', bc_ymax = 'periodic', &
            & deallocate_after = .true.)

  call mg_interface(input)

  phi = input%phi

    ! test against analytical solution

    do iy = 1, ny
    do ix = 1, nx
      x = xc(ix)
      y = yc(iy)
      C1 = A / k / pi2
      C2 = B
      analytic(ix,iy) = - A * sin(k * pi2 * x) *(1.0_num/k/pi2)**2 + C1*x + C2
    enddo
    enddo

    L2 = sqrt(sum(abs(analytic(1:nx,1:ny)-phi(1:nx,1:ny))**2) / real(nx*ny,num))

    print *,'L2',L2

    L2_arr(power-power_min+1) = L2
    n_arr(power-power_min+1) = real(nx,num)

    ! deallocate all so can do again

    deallocate(xc)
    deallocate(yc)
    deallocate(f)
    deallocate(phi)
    deallocate(analytic)

  enddo different_resolutions

  print *, 'L2 _arr',L2_arr
  print *, 'n _arr',n_arr

  call execute_command_line("rm -rf test6_l2.dat")
  call execute_command_line("rm -rf test6_nx.dat")

  open(10, file="test6_l2.dat", access="stream")
  write(10) L2_arr
  close(10)

  open(10, file="test6_nx.dat", access="stream")
  write(10) n_arr
  close(10)

  call execute_command_line("python test6_plots.py")
  call execute_command_line("rm test6_l2.dat")
  call execute_command_line("rm test6_nx.dat")

end program test6_reverse


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: beta = 0.99d0
    real*8, parameter :: alpha = 0.40d0
    real*8, parameter :: delta = 0.019d0
    real*8, parameter :: k0 = 10d0

    ! numerical parameters
    real*8, parameter :: k_l = 5d0
    real*8, parameter :: k_u = 100d0
    real*8, parameter :: sig = 1d-6
    integer, parameter :: itermax = 2000

    ! counter variables
    integer :: it, ik, iter

    ! time path of consumption and capital
    integer, parameter :: TT = 360
    real*8 :: c_t(0:TT), k_t(0:TT), y_t(0:TT)

    ! policy function
    integer, parameter :: NK = 100
    real*8 :: k(0:NK), c(0:NK)

    ! variables to numerically determine policy function
    real*8 :: c_new(0:NK), coeff_c(NK+3)
    real*8 :: con_lev, x_in
    logical :: check

    ! variables to communicate with function
    real*8 :: k_com

contains

    ! the first order condition
    function foc(x_in)

        use toolbox

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, kplus, cplus

        ! future capital
        kplus = (1d0-delta)*k_com + k_com**alpha - x_in

        ! calculate future consumption
        cplus = spline_eval(kplus, coeff_c, k_l, k_u)

        ! get first order condition
        foc = x_in - (beta*(1d0+alpha*kplus**(alpha-1d0)-delta))**(-gamma)*cplus

    end function

end module


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shags.f
c
c     this file contains code and documentation for subroutines
c     shags and shagsi
c
c ... files which must be loaded with shags.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shags(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    1                    wshags,lshags,work,lwork,ierror)
c
c     subroutine shags performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on a gaussian grid in colatitude
c     and an equally spaced grid in longitude.  the associated
c     legendre functions are stored rather than recomputed as they
c     are in subroutine shagc.  the analysis is described below
c     at output parameters a,b.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shags,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the gaussian
c            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
c            the index ranges are defined above at the input parameter
c            isym.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shags. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shags. jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shags. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shags. ndab must be at least nlat
c
c     wshags an array which must be initialized by subroutine shagsi.
c            once initialized, wshags can be used repeatedly by shags
c            as long as nlat and nlon remain unchanged.  wshags must
c            not be altered between calls of shags.
c
c     lshags the dimension of the array wshags as it appears in the
c            program that calls shags. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshags must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shags. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c
c            if isym is zero then lwork must be at least
c
c                  nlat*nlon*(nt+1)
c
c            if isym is nonzero then lwork must be at least
c
c                  l2*nlon*(nt+1)
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shags. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta).
c
c     2. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon of
c                       g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon of
c                       g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c
c     3. the gaussian points and weights on the sphere
c        (computed by subroutine gaqd).
c
c        theta(1),...,theta(nlat) (gaussian pts in radians)
c        wts(1),...,wts(nlat) (corresponding gaussian weights)
c
c
c     4. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c
c     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
c     are given by
c
c     a(m+1,n+1)     =  the sum from i=1 to i=nlat of
c                       c(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     b(m+1,n+1)      = the sum from i=1 to nlat of
c                       s(m+1,i)*wts(i)*pbar(m,n,theta(i))
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshags
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork,
c    +                  ierror)
c
c     subroutine shagsi initializes the array wshags which can then
c     be used repeatedly by subroutines shags. it precomputes
c     and stores in wshags quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshags an array which must be initialized by subroutine shagsi.
c            once initialized, wshags can be used repeatedly by shags
c            as long as nlat and nlon remain unchanged.  wshags must
c            not be altered between calls of shags.
c
c     lshags the dimension of the array wshags as it appears in the
c            program that calls shags. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshags must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shagsi. lwork must be at least
c            4*nlat*(nlat+2)+2 in the routine calling shagsi
c
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the length of dwork in the calling routine.  ldwork must
c             be at least nlat*(nlat+4)
c
c     output parameter
c
c     wshags an array which must be initialized before calling shags or
c            once initialized, wshags can be used repeatedly by shags or
c            as long as nlat and nlon remain unchanged.  wshags must not
c            altered between calls of shasc.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshags
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c            = 6  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      subroutine shags(nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab,
     1                    wshags,lshags,work,lwork,ierror)
c     subroutine shags performs the spherical harmonic analysis on
c     a gaussian grid on the array(s) in g and returns the coefficients
c     in array(s) a,b. the necessary legendre polynomials are fully
c     stored in this version.
c
      dimension g(idg,jdg,1),a(mdab,ndab,1),b(mdab,ndab,1),
     1          wshags(lshags),work(lwork)
c     check input parameters
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
      ierror = 3
      if (mode.lt.0 .or.mode.gt.2) return
c     set m limit for pmn
      l = min0((nlon+2)/2,nlat)
c     set gaussian point nearest equator pointer
      late = (nlat+mod(nlat,2))/2
c     set number of grid points for analysis/synthesis
      lat = nlat
      if (mode.ne.0) lat = late
      ierror = 4
      if (nt.lt.1) return
      ierror = 5
      if (idg.lt.lat) return
      ierror = 6
      if (jdg.lt.nlon) return
      ierror = 7
      if(mdab .lt. l) return
      ierror = 8
      if(ndab .lt. nlat) return
      l1 = l
      l2 = late
      ierror = 9
c     check permanent work space length
c
      lp= nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
      if(lshags.lt.lp) return
      ierror = 10
c     check temporary work space length
      if (mode.eq.0 .and. lwork.lt.nlat*nlon*(nt+1)) return
      if (mode.ne.0 .and. lwork.lt.l2*nlon*(nt+1)) return
      ierror = 0
c     set starting address for gaussian wts ,fft values,
c     and fully stored legendre polys in wshags
      iwts = 1
      ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1
      ipmn = ifft+nlon+15
c     set pointer for internal storage of g
      iw = lat*nlon*nt+1
      call shags1(nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab,
     1wshags(iwts),wshags(ifft),wshags(ipmn),late,work,work(iw))
      return
      end

      subroutine shags1(nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab,
     1                  ndab,wts,wfft,pmn,late,g,work)
      dimension gs(idg,jdg,nt),a(mdab,ndab,nt),
     1          b(mdab,ndab,nt),g(lat,nlon,nt)
      dimension wfft(1),pmn(late,1),wts(nlat),work(1)
c     set gs array internally in shags1
      do 100 k=1,nt
      do 100 j=1,nlon
      do 100 i=1,lat
      g(i,j,k) = gs(i,j,k)
  100 continue

c     do fourier transform
      do 101 k=1,nt
      call hrfftf(lat,nlon,g(1,1,k),lat,wfft,work)
  101 continue

c     scale result
      sfn = 2.0/float(nlon)
      do 102 k=1,nt
      do 102 j=1,nlon
      do 102 i=1,lat
      g(i,j,k) = sfn*g(i,j,k)
  102 continue

c     compute using gaussian quadrature
c     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
c     here ga,gb are the cos(phi),sin(phi) coefficients of
c     the fourier expansion of g(theta,phi) in phi.  as a result
c     of the above fourier transform they are stored in array
c     g as follows:
c     for each theta(i) and k= l-1
c     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
c     correspond to
c     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-2)
c     whenever 2*l-2 = nlon exactly
c     initialize coefficients to zero
      do 103 k=1,nt
      do 103 np1=1,nlat
      do 103 mp1=1,l
      a(mp1,np1,k) = 0.0
      b(mp1,np1,k) = 0.0
  103 continue
c     set mp1 limit on b(mp1) calculation
      lm1 = l
      if (nlon .eq. l+l-2) lm1 = l-1

      if (mode.eq.0) then
c     for full sphere (mode=0) and even/odd reduction:
c     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
c     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
      nl2 = nlat/2
      do 104 k=1,nt
      do 104 j=1,nlon
      do 105 i=1,nl2
      is = nlat-i+1
      t1 = g(i,j,k)
      t2 = g(is,j,k)
      g(i,j,k) = wts(i)*(t1+t2)
      g(is,j,k) = wts(i)*(t1-t2)
  105 continue
c     adjust equator if necessary(nlat odd)
      if (mod(nlat,2).ne.0) g(late,j,k) = wts(late)*g(late,j,k)
  104 continue
c     set m = 0 coefficients first
      mp1 = 1
      m = 0
      mml1 = m*(2*nlat-m-1)/2
      do 106 k=1,nt
      do 106 i=1,late
      is = nlat-i+1
      do 107 np1=1,nlat,2
c     n even
      a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(i,mml1+np1)
  107 continue
      do 108 np1=2,nlat,2
c     n odd
      a(1,np1,k) = a(1,np1,k)+g(is,1,k)*pmn(i,mml1+np1)
  108 continue
  106 continue
c     compute m.ge.1  coefficients next
      do 109 mp1=2,lm1
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
      mp2 = mp1+1
      do 110 k=1,nt
      do 111 i=1,late
      is = nlat-i+1
c     n-m even
      do 112 np1=mp1,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(i,mml1+np1)
      b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(i,mml1+np1)
  112 continue
c     n-m odd
      do 113 np1=mp2,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(is,2*m,k)*pmn(i,mml1+np1)
      b(mp1,np1,k) = b(mp1,np1,k)+g(is,2*m+1,k)*pmn(i,mml1+np1)
  113 continue
  111 continue
  110 continue
  109 continue
      if (nlon .eq. l+l-2) then
c     compute m=l-1, n=l-1,l,...,nlat-1 coefficients
      m = l-1
      mml1 = m*(2*nlat-m-1)/2
      do 114 k=1,nt
      do 114 i=1,late
      is = nlat-i+1
      do 124 np1=l,nlat,2
      mn = mml1+np1
      a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(i,mn)
  124 continue
c     n-m  odd
      lp1 = l+1
      do 125 np1=lp1,nlat,2
      mn = mml1+np1
      a(l,np1,k) = a(l,np1,k)+0.5*g(is,nlon,k)*pmn(i,mn)
  125 continue
  114 continue
      end if

      else

c     half sphere
c     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
      nl2 = nlat/2
      do 116  k=1,nt
      do 116 j=1,nlon
      do 115 i=1,nl2
      g(i,j,k) = wts(i)*(g(i,j,k)+g(i,j,k))
  115 continue
c     adjust equator separately if a grid point
      if (nl2.lt.late) g(late,j,k) = wts(late)*g(late,j,k)
  116 continue

c     set m = 0 coefficients first
      mp1 = 1
      m = 0
      mml1 = m*(2*nlat-m-1)/2
      ms = 1
      if (mode.eq.1) ms = 2
      do 117 k=1,nt
      do 117 i=1,late
      do 117 np1=ms,nlat,2
      a(1,np1,k) = a(1,np1,k)+g(i,1,k)*pmn(i,mml1+np1)
  117 continue

c     compute m.ge.1  coefficients next
      do 118 mp1=2,lm1
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
      ms = mp1
      if (mode.eq.1) ms = mp1+1
      do 119 k=1,nt
      do 119 i=1,late
      do 119 np1=ms,nlat,2
      a(mp1,np1,k) = a(mp1,np1,k)+g(i,2*m,k)*pmn(i,mml1+np1)
      b(mp1,np1,k) = b(mp1,np1,k)+g(i,2*m+1,k)*pmn(i,mml1+np1)
  119 continue
  118 continue

      if (nlon.eq.l+l-2) then
c     compute n=m=l-1 coefficients last
      m = l-1
      mml1 = m*(2*nlat-m-1)/2
c     set starting n for mode even
      ns = l
c     set starting n for mode odd
      if (mode.eq.1) ns = l+1
      do 120 k=1,nt
      do 120 i=1,late
      do 120 np1=ns,nlat,2
      mn = mml1+np1
      a(l,np1,k) = a(l,np1,k)+0.5*g(i,nlon,k)*pmn(i,mn)
  120 continue
      end if

      end if

      return
      end
      subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork,
     +                  ierror)
c
c     this subroutine must be called before calling shags or shsgs with
c     fixed nlat,nlon. it precomputes the gaussian weights, points
c     and all necessary legendre polys and stores them in wshags.
c     these quantities must be preserved when calling shags or shsgs
c     repeatedly with fixed nlat,nlon.  dwork must be of length at
c     least nlat*(nlat+4) in the routine calling shagsi.  This is
c     not checked.  undetectable errors will result if dwork is
c     smaller than nlat*(nlat+4).
c
      dimension wshags(lshags),work(lwork)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+1)/2
      l1 = l
      l2 = late
c     check permanent work space length
      ierror = 3
      lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
      if(lshags.lt.lp) return
      ierror = 4
c     check temporary work space
      if (lwork.lt.4*nlat*(nlat+2)+2) return
      ierror = 5
c     check double precision temporary space
      if (ldwork .lt. nlat*(nlat+4)) return
      ierror = 0
c     set preliminary quantites needed to compute and store legendre polys
      ldw = nlat*(nlat+4)
      call shagsp(nlat,nlon,wshags,lshags,dwork,ldwork,ierror)
      if (ierror.ne.0) return
c     set legendre poly pointer in wshags
      ipmnf = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+nlon+16
      call shagss1(nlat,l,late,wshags,work,wshags(ipmnf))
      return
      end
      subroutine shagss1(nlat,l,late,w,pmn,pmnf)
      dimension w(1),pmn(nlat,late,3),pmnf(late,1)
c     compute and store legendre polys for i=1,...,late,m=0,...,l-1
c     and n=m,...,l-1
      do i=1,nlat
	do j=1,late
	  do k=1,3
	   pmn(i,j,k) = 0.0
	  end do
	end do
      end do
      do 100 mp1=1,l
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
c     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
      mode = 0
      call legin(mode,l,nlat,m,w,pmn,km)
c     store above in pmnf
      do 101 np1=mp1,nlat
      mn = mml1+np1
      do 102 i=1,late
      pmnf(i,mn) = pmn(np1,i,km)
  102 continue
  101 continue
  100 continue
      return
      end
      subroutine shagsp(nlat,nlon,wshags,lshags,dwork,ldwork,ierror)
      dimension wshags(lshags)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+mod(nlat,2))/2
      l1 = l
      l2 = late
      ierror = 3
c     check permanent work space length
      if (lshags .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      if (ldwork.lt.nlat*(nlat+4))return
      ierror = 0
c     set pointers
      i1 = 1
      i2 = i1+nlat
      i3 = i2+nlat*late
      i4 = i3+nlat*late
      i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1)
      i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1)
      i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1)
c     set indices in temp work for double precision gaussian wts and pts
      idth = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      idwts = idth+nlat
      iw = idwts+nlat
      call shagsp1(nlat,nlon,l,late,wshags(i1),wshags(i2),wshags(i3),
     1wshags(i4),wshags(i5),wshags(i6),wshags(i7),dwork(idth),
     2dwork(idwts),dwork(iw),ierror)
      if (ierror.ne.0) ierror = 6
      return
      end

      subroutine shagsp1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel,
     +                   wfft,dtheta,dwts,work,ier)
      dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1),
     1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat)
      double precision pb,dtheta,dwts,work(*)
      indx(m,n) = (n-1)*(n-2)/2+m-1
      imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1
      call hrffti(nlon,wfft)

c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+2)
      lw = nlat*(nlat+2)
      call gaqd(nlat,dtheta,dwts,work,lw,ier)
      if (ier.ne.0) return

c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      do 100 i=1,nlat
      wts(i) = dwts(i)
  100 continue
c     initialize p0n,p1n using double precision dnlfk,dnlft
      do 101 np1=1,nlat
      do 101 i=1,late
      p0n(np1,i) = 0.0
      p1n(np1,i) = 0.0
  101 continue
c     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      call dnlfk(m,n,work)
      do 103 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(1,i) = pb
  103 continue
c     compute p0n,p1n for all theta(i) when n.gt.0
      do 104 np1=2,nlat
      n = np1-1
      m = 0
      call dnlfk(m,n,work)
      do 105 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(np1,i) = pb
  105 continue
c     compute m=1 legendre polynomials for all n and theta(i)
      m = 1
      call dnlfk(m,n,work)
      do 106 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p1n(np1,i) = pb
  106 continue
  104 continue
c
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      do 107 n=2,nlat
      mlim = min0(n,l)
      do 107 m=2,mlim
      imn = indx(m,n)
      if (n.ge.l) imn = imndx(m,n)
      abel(imn)=sqrt(float((2*n+1)*(m+n-2)*(m+n-3))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      bbel(imn)=sqrt(float((2*n+1)*(n-m-1)*(n-m))/
     1               float(((2*n-3)*(m+n-1)*(m+n))))
      cbel(imn)=sqrt(float((n-m+1)*(n-m+2))/
     1               float(((n+m-1)*(n+m))))
  107 continue
      return
      end


      SUBROUTINE INTERP(BUF,T,NCF,NCM,NA,IFL,PV)
C
C+++++++++++++++++++++++++++++++++
C
C     THIS SUBROUTINE DIFFERENTIATES AND INTERPOLATES A
C     SET OF CHEBYSHEV COEFFICIENTS TO GIVE POSITION AND VELOCITY
C
C     CALLING SEQUENCE PARAMETERS:
C
C       INPUT:
C
C         BUF   1ST LOCATION OF ARRAY OF D.P. CHEBYSHEV COEFFICIENTS OF POSITION
C
C           T   T(1) IS DP FRACTIONAL TIME IN INTERVAL COVERED BY
C               COEFFICIENTS AT WHICH INTERPOLATION IS WANTED
C               (0 .LE. T(1) .LE. 1).  T(2) IS DP LENGTH OF WHOLE
C               INTERVAL IN INPUT TIME UNITS.
C
C         NCF   # OF COEFFICIENTS PER COMPONENT
C
C         NCM   # OF COMPONENTS PER SET OF COEFFICIENTS
C
C          NA   # OF SETS OF COEFFICIENTS IN FULL ARRAY
C               (I.E., # OF SUB-INTERVALS IN FULL INTERVAL)
C
C          IFL  INTEGER FLAG: =1 FOR POSITIONS ONLY
C                             =2 FOR POS AND VEL
C
C
C       OUTPUT:
C
C         PV   INTERPOLATED QUANTITIES REQUESTED.  DIMENSION
C               EXPECTED IS PV(NCM,IFL), DP.
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      SAVE
C
      DOUBLE PRECISION BUF(NCF,NCM,*),T(2),PV(NCM,*),PC(18),VC(18)

C
      DATA NP/2/
      DATA NV/3/
      DATA TWOT/0.D0/
      DATA PC(1),PC(2)/1.D0,0.D0/
      DATA VC(2)/1.D0/
C
C       ENTRY POINT. GET CORRECT SUB-INTERVAL NUMBER FOR THIS SET
C       OF COEFFICIENTS AND THEN GET NORMALIZED CHEBYSHEV TIME
C       WITHIN THAT SUBINTERVAL.
C
      DNA=DBLE(NA)
      DT1=DINT(T(1))
      TEMP=DNA*T(1)
      L=IDINT(TEMP-DT1)+1

C         TC IS THE NORMALIZED CHEBYSHEV TIME (-1 .LE. TC .LE. 1)

      TC=2.D0*(DMOD(TEMP,1.D0)+DT1)-1.D0

C       CHECK TO SEE WHETHER CHEBYSHEV TIME HAS CHANGED,
C       AND COMPUTE NEW POLYNOMIAL VALUES IF IT HAS.
C       (THE ELEMENT PC(2) IS THE VALUE OF T1(TC) AND HENCE
C       CONTAINS THE VALUE OF TC ON THE PREVIOUS CALL.)

      IF(TC.NE.PC(2)) THEN
        NP=2
        NV=3
        PC(2)=TC
        TWOT=TC+TC
      ENDIF
C
C       BE SURE THAT AT LEAST 'NCF' POLYNOMIALS HAVE BEEN EVALUATED
C       AND ARE STORED IN THE ARRAY 'PC'.
C
      IF(NP.LT.NCF) THEN
        DO 1 I=NP+1,NCF
        PC(I)=TWOT*PC(I-1)-PC(I-2)
    1   CONTINUE
        NP=NCF
      ENDIF
C
C       INTERPOLATE TO GET POSITION FOR EACH COMPONENT
C
      DO 2 I=1,NCM
      PV(I,1)=0.D0
      DO 3 J=NCF,1,-1
      PV(I,1)=PV(I,1)+PC(J)*BUF(J,I,L)
    3 CONTINUE
    2 CONTINUE
      IF(IFL.LE.1) RETURN
C
C       IF VELOCITY INTERPOLATION IS WANTED, BE SURE ENOUGH
C       DERIVATIVE POLYNOMIALS HAVE BEEN GENERATED AND STORED.
C
      VFAC=(DNA+DNA)/T(2)
      VC(3)=TWOT+TWOT
      IF(NV.LT.NCF) THEN
        DO 4 I=NV+1,NCF
        VC(I)=TWOT*VC(I-1)+PC(I-1)+PC(I-1)-VC(I-2)
    4   CONTINUE
        NV=NCF
      ENDIF
C
C       INTERPOLATE TO GET VELOCITY FOR EACH COMPONENT
C
      DO 5 I=1,NCM
      PV(I,2)=0.D0
      DO 6 J=NCF,2,-1
      PV(I,2)=PV(I,2)+VC(J)*BUF(J,I,L)
    6 CONTINUE
      PV(I,2)=PV(I,2)*VFAC
    5 CONTINUE
C
      RETURN
C
      END

C+++++++++++++++++++++++++
C


	SUBROUTINE
     .	FISHEREST
     .	(X0,X1,X2,FX1,FX2,ALPHA,B,C,D,E)
!MS$ATTRIBUTES REFERENCE :: B
!MS$ATTRIBUTES REFERENCE :: C
!MS$ATTRIBUTES REFERENCE :: D
!MS$ATTRIBUTES REFERENCE :: E
      USE MSIMSLMS
	IMPLICIT NONE

	REAL X0,X1,X2,FX1,FX2,ALPHA,B,C,D,E

	INTEGER IPATH, LDA, N
	PARAMETER  (IPATH=1, LDA=4, N=4)
	REAL       A(LDA,LDA), B_ARRAY(N), Y(N)

C
C Code:
C
	B_ARRAY(1)=0.0
	B_ARRAY(2)=FX1
	B_ARRAY(3)=FX2
	B_ARRAY(4)=ALPHA

	A(1,1)=3.*X0**2
	A(2,1)=X1**3
	A(3,1)=X2**3
	A(4,1)=X0**3

	A(1,2)=2.*X0
	A(2,2)=X1**2
	A(3,2)=X2**2
	A(4,2)=X0**2

	A(1,3)=1.
	A(2,3)=X1
	A(3,3)=X2
	A(4,3)=X0

	A(1,4)=0.
	A(2,4)=1.
	A(3,4)=1.
	A(4,4)=1.

	CALL LSARG (N, A, LDA, B_ARRAY, IPATH, Y)

	B=Y(1)
	C=Y(2)
	D=Y(3)
	E=Y(4)

	RETURN
	END


program potencial
use iso_fortran_env
use OMP_LIB

implicit none

integer, parameter   :: n = 5000000
real, dimension(:), allocatable   :: ID, x, y, z, m, ep
real, parameter      :: G = 4.299e+4
real                 :: dist
integer              :: i, j

allocate(ID(n), x(n), y(n), z(n), m(n), ep(n))

!-------------leo las posiciones de las particulas---------------------
open(20, file='/home/vcristiani/potencial/agama_M5.dat', status='old')
do i=1, n
        read(20,*) ID(i), x(i), y(i), z(i), m(i)
end do
 close(20)

!======================================================================
!Calcula la energia potencial específica de cada una de las particulas

!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED (x,y,z,m,ep) &
!$OMP PRIVATE(i,j,dist)
!$OMP DO SCHEDULE(DYNAMIC)
do i = 1, n
    ep(i) = 0.
    do j = 1, n
        if (i /= j) then

            dist = sqrt((x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2)
            ep(i) = ep(i) + m(j)/dist

        end if
    end do
    ep(i) = ep(i)*G
end do
!$OMP END DO
!$OMP END PARALLEL

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

!-------------escribo los potenciales de las particulas---------------------
open(30, file='/home/vcristiani/potencial/potencial_agama_M5.dat', status='new')
do i = 1,n
        write(30,*) ep(i)
end do
 close(30)

deallocate(ID, x, y, z, m, ep)

end program


program main

  use numeric_kinds, only: dp
  use davidson, only: generalized_eigensolver
  use test_utils, only: apply_mtx_to_vect, apply_stx_to_vect, compute_matrix_on_the_fly, compute_stx_on_the_fly, write_matrix
  use array_utils, only: diagonal, norm, generate_diagonal_dominant

  implicit none

  integer, parameter :: dim = 50
  real(dp), dimension(3) :: eigenvalues_DPR
  real(dp), dimension(dim, 3) :: eigenvectors_DPR
  real(dp), dimension(dim) :: xs, zs
  real(dp), dimension(dim, dim) :: mtx, stx
  integer :: iter_i, j

  do j=1, dim
     mtx(:, j) = compute_matrix_on_the_fly(j, dim)
     stx(:, j) = compute_stx_on_the_fly(j, dim)
  end do

  call generalized_eigensolver(apply_mtx_to_vect, eigenvalues_DPR, eigenvectors_DPR, 3, "DPR", 1000, &
       1d-8, iter_i, 20, apply_stx_to_vect)

  print "(a, 3f8.4)", "eigenvalues: ", eigenvalues_DPR
  print *, "Test 1"
  print *, "Check that eigenvalue equation:  H V = l B V holds"
  print *, "DPR method:"
  do j=1,3
     xs = matmul(mtx, eigenvectors_DPR(:, j)) - (eigenvalues_DPR(j) * matmul(stx, eigenvectors_DPR(:, j)))
     print "(a, e10.3)", "error: ", norm(xs)
     print "(a, i2, a, e12.5, a, l)", "eigenvalue ", j, ": ", eigenvalues_DPR(j), " succeeded: ", norm(xs) < 1d-8
  end do

  print *, "Test 2"
  print *, "If V are the eigenvector then V * V^T = I"
  zs = diagonal(matmul(eigenvectors_DPR, transpose(eigenvectors_DPR)))
  ! There are only 3 eigenvectors
  print "(a, l)", "DPR method: ", norm(zs(:3)) < sqrt(3.d0)

end program main


! Intrinsics SELECTED_INT_KIND, SELECTED_REAL_KIND, PRECISION, RANGE,
! RADIX, DIGITS

module m1
  ! INTEGER(KIND=1)  handles  0 <= P < 3
  ! INTEGER(KIND=2)  handles  3 <= P < 5
  ! INTEGER(KIND=4)  handles  5 <= P < 10
  ! INTEGER(KIND=8)  handles 10 <= P < 19
  ! INTEGER(KIND=16) handles 19 <= P < 39
  integer, parameter :: iranges(*) = &
    [range(0_1), range(0_2), range(0_4), range(0_8), range(0_16)]
  logical, parameter :: ircheck = all([2, 4, 9, 18, 38] == iranges)
  integer, parameter :: intpvals(*) = [0, 2, 3, 4, 5, 9, 10, 18, 19, 38, 39]
  integer, parameter :: intpkinds(*) = &
    [(selected_int_kind(intpvals(j)),j=1,size(intpvals))]
  logical, parameter :: ipcheck = &
    all([1, 1, 2, 2, 4, 4, 8, 8, 16, 16, -1] == intpkinds)

  ! REAL(KIND=2)  handles  0 <= P < 4  (if available)
  ! REAL(KIND=3)  handles  0 <= P < 3  (if available)
  ! REAL(KIND=4)  handles  4 <= P < 7
  ! REAL(KIND=8)  handles  7 <= P < 16
  ! REAL(KIND=10) handles 16 <= P < 19 (if available; ifort is KIND=16)
  ! REAL(KIND=16) handles 19 <= P < 34 (would be 32 with Power double/double)
  integer, parameter :: realprecs(*) = &
    [precision(0._2), precision(0._3), precision(0._4), precision(0._8), &
     precision(0._10), precision(0._16)]
  logical, parameter :: rpreccheck = all([3, 2, 6, 15, 18, 33] == realprecs)
  integer, parameter :: realpvals(*) = [0, 3, 4, 6, 7, 15, 16, 18, 19, 33, 34]
  integer, parameter :: realpkinds(*) = &
    [(selected_real_kind(realpvals(j),0),j=1,size(realpvals))]
  logical, parameter :: realpcheck = &
    all([2, 2, 4, 4, 8, 8, 10, 10, 16, 16, -1] == realpkinds)
  ! REAL(KIND=2)  handles  0 <= R < 5 (if available)
  ! REAL(KIND=3)  handles  5 <= R < 38 (if available, same range as KIND=4)
  ! REAL(KIND=4)  handles  5 <= R < 38 (if no KIND=3)
  ! REAL(KIND=8)  handles 38 <= R < 308
  ! REAL(KIND=10) handles 308 <= R < 4932 (if available; ifort is KIND=16)
  ! REAL(KIND=16) handles 4932 <= R < 9864 (except Power double/double)
  integer, parameter :: realranges(*) = &
    [range(0._2), range(0._3), range(0._4), range(0._8), range(0._10), &
     range(0._16)]
  logical, parameter :: rrangecheck = &
    all([4, 37, 37, 307, 4931, 9863] == realranges)
  integer, parameter :: realrvals(*) = &
    [0, 4, 5, 37, 38, 307, 308, 4931, 4932, 9863, 9864]
  integer, parameter :: realrkinds(*) = &
    [(selected_real_kind(0,realrvals(j)),j=1,size(realrvals))]
  logical, parameter :: realrcheck = &
    all([2, 2, 3, 3, 8, 8, 10, 10, 16, 16, -2] == realrkinds)
  logical, parameter :: radixcheck = &
    all([radix(0._2), radix(0._3), radix(0._4), radix(0._8), &
         radix(0._10), radix(0._16)] == 2)
  integer, parameter :: intdigits(*) = &
    [digits(0_1), digits(0_2), digits(0_4), digits(0_8), digits(0_16)]
  logical, parameter :: intdigitscheck = &
    all([7, 15, 31, 63, 127] == intdigits)
  integer, parameter :: realdigits(*) = &
    [digits(0._2), digits(0._3), digits(0._4), digits(0._8), digits(0._10), &
     digits(0._16)]
  logical, parameter :: realdigitscheck = &
    all([11, 8, 24, 53, 64, 112] == realdigits)
end module m1
!Expect: m1.mod
!module m1
!integer(4),parameter::iranges(1_8:*)=[INTEGER(4)::2_4,4_4,9_4,18_4,38_4]
!logical(4),parameter::ircheck=.true._4
!intrinsic::all
!integer(4),parameter::intpvals(1_8:*)=[INTEGER(4)::0_4,2_4,3_4,4_4,5_4,9_4,10_4,18_4,19_4,38_4,39_4]
!integer(4),parameter::intpkinds(1_8:*)=[INTEGER(4)::1_4,1_4,2_4,2_4,4_4,4_4,8_4,8_4,16_4,16_4,-1_4]
!logical(4),parameter::ipcheck=.true._4
!integer(4),parameter::realprecs(1_8:*)=[INTEGER(4)::3_4,2_4,6_4,15_4,18_4,33_4]
!logical(4),parameter::rpreccheck=.true._4
!integer(4),parameter::realpvals(1_8:*)=[INTEGER(4)::0_4,3_4,4_4,6_4,7_4,15_4,16_4,18_4,19_4,33_4,34_4]
!integer(4),parameter::realpkinds(1_8:*)=[INTEGER(4)::2_4,2_4,4_4,4_4,8_4,8_4,10_4,10_4,16_4,16_4,-1_4]
!logical(4),parameter::realpcheck=.true._4
!integer(4),parameter::realranges(1_8:*)=[INTEGER(4)::4_4,37_4,37_4,307_4,4931_4,9863_4]
!logical(4),parameter::rrangecheck=.true._4
!integer(4),parameter::realrvals(1_8:*)=[INTEGER(4)::0_4,4_4,5_4,37_4,38_4,307_4,308_4,4931_4,4932_4,9863_4,9864_4]
!integer(4),parameter::realrkinds(1_8:*)=[INTEGER(4)::2_4,2_4,3_4,3_4,8_4,8_4,10_4,10_4,16_4,16_4,-2_4]
!logical(4),parameter::realrcheck=.true._4
!logical(4),parameter::radixcheck=.true._4
!integer(4),parameter::intdigits(1_8:*)=[INTEGER(4)::7_4,15_4,31_4,63_4,127_4]
!logical(4),parameter::intdigitscheck=.true._4
!integer(4),parameter::realdigits(1_8:*)=[INTEGER(4)::11_4,8_4,24_4,53_4,64_4,112_4]
!logical(4),parameter::realdigitscheck=.true._4
!end


      PROGRAM xksone
C     driver for routine ksone
      INTEGER NPTS
      REAL EPS
      PARAMETER(NPTS=1000,EPS=0.1)
      INTEGER i,idum,j
      REAL d,data(NPTS),factr,gasdev,prob,var
      EXTERNAL func
      idum=-5
      write(*,'(/1x,t5,a,t24,a,t44,a/)')
     *     'Variance Ratio','K-S Statistic','Probability'
      do 12 i=1,11
        var=1.0+(i-1)*EPS
        factr=sqrt(var)
        do 11 j=1,NPTS
          data(j)=factr*abs(gasdev(idum))
11      continue
        call ksone(data,NPTS,func,d,prob)
        write(*,'(1x,f14.6,f18.6,e20.4)') var,d,prob
12    continue
      END
      REAL FUNCTION func(x)
      REAL erf,x,y
      y=x/sqrt(2.0)
      func=erf(y)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xksone.for


module fac_mod
    use, intrinsic :: iso_fortran_env, only : i32 => INT32
    implicit none

    public :: fac

contains

    integer(kind=i32) function fac(n)
        implicit none
        integer(kind=i32), intent(in) :: n
        integer(kind=i32) :: r = 1_i32
        integer :: i
        do i = 2, n
            r = r*i
        end do
        fac = r
    end function fac

end module fac_mod