       subroutine apomak
*++
*
* APOMASK V1.0 - create an apodising mask for image restoration
*
* This is an IRAF application written using the F77/VOS.
*
* Purpose:
*
* Create an image which is zero everywhere except for a central circular region
* where it is one. The region outside the central circle fades off as a gaussian.
* The user supplies the radius of the central circle and the sigma of the fade-off.
*
* History:
*
* First version, Richard Hook, ST-ECF, Jan 92
* Added limb darkening, Richard Hook, ST-ECF, Apr 94
* Renamed APOMASK, Richard Hook, Mar 99
* Given version number, changed parameter names to all lowercase,
*  Richard Hook, February 2000
*
*--

* Iraf global space
*
      real Memr(1)
      integer Memi(1)
      equivalence (Memr,Memi)
      common /Mem/Memr

* Local variables
      integer nx,ny,dims(2),id
      character*80 image
      real rad,sigma,xpos,ypos,k

* Get the name of the output image
      call uclgst('output',image,istat)

* and its dimensions
      call uclgsi('xdim',nx,istat)
      call uclgsi('ydim',ny,istat)

      dims(1)=nx
      dims(2)=ny

* and the size and fade-off parameters
      call uclgsr('radius',rad,istat)
      call uclgsr('sigma',sigma,istat)
      call uclgsr('k',k,istat)

* and the position for the centre of the mask
      call uclgsr('xpos',xpos,istat)
      call uclgsr('ypos',ypos,istat)

* Create the image
      call uimcre(image,6,2,dims,id,istat)
      if(istat.ne.0) then
         call umsput('Unable to create output image',
     :               1,0,istat)
         go to 99
      endif

* Allocate memory for the image
      call udmget(nx*ny,6,ipnt,istat)
      if(istat.ne.0) then
         call umsput('Unable to allocate memory for data',
     :               1,0,istat)
         go to 99
      endif

* Fill the image
      call circle(Memr(ipnt),nx,ny,rad,sigma,k,xpos,ypos)

* Write out the result
      call uips2r(id,1,nx,1,ny,Memr(ipnt),istat)

 99   continue
      call uimclo(id,istat)
      call udmfre(ipnt,6,istat)

      end

      subroutine circle(data,nx,ny,rad,sigma,k,xcen,ycen)
*
* Fill in a circular region with 1s and the rest zero except for
* a fade off around the circle with a specified sigma.
*
      implicit none

      integer nx,ny
      real data(nx,ny),rad,sigma,dx,dy,xcen,ycen,k,r
      integer i,j

      do j=1,ny
          dy=real(j)-ycen
          do i=1,nx
             dx=real(i)-xcen
             r=sqrt(dx*dx+dy*dy)
             if(r.le.rad) then
                data(i,j)=(1.0-(r/rad)**2)**(k-0.5)
             else if(r.le.rad+5*sigma) then
                data(i,j)=exp(-((r-rad)**2.0/(2.0*sigma*sigma)))
             else
                data(i,j)=0.0
             endif
          enddo
      enddo

      end


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
module type_AssociatedLegendrePolynomialGenerator

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI, HALF_PI

    use type_FastFourierTransform, only: &
        FastFourierTransform

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: AssociatedLegendrePolynomialGenerator
    public :: alfk, lfp, lfpt, lfim, lfin, get_legendre_function

    type, public :: AssociatedLegendrePolynomialGenerator
    contains
        ! Type-bound procedures
        procedure, nopass :: alfk
        procedure, nopass :: lfim
        procedure, nopass :: lfin
        procedure, nopass :: lfp
        procedure, nopass :: lfpt
        procedure, nopass :: get_legendre_function
    end type AssociatedLegendrePolynomialGenerator

contains

    subroutine get_legendre_function(lat, ntrunc, legfunc)

        ! Dummy arguments
        real(wp),              intent(in)  :: lat
        integer(ip),           intent(in)  :: ntrunc
        real(wp), allocatable, intent(out) :: legfunc(:)

        ! Local variables
        integer(ip)  :: alloc_stat, required_size, workspace_size

        !  Allocate memory
        required_size = (ntrunc + 1) * (ntrunc + 2)/2
        allocate (legfunc(required_size), stat=alloc_stat)

        ! Check allocation status
        if (alloc_stat /= 0) then
            error stop "Failed to allocate legfunc in get_legendre_function"
        end if

        ! Compute required workspace size
        workspace_size = (ntrunc/2)+1

        block
            real(wp), parameter :: DEGREE_TO_RADIAN = PI/180
            real(wp)            :: cp(workspace_size), theta
            integer(ip)         :: n, m, nm, nmstrt ! Counters

            theta = HALF_PI - (DEGREE_TO_RADIAN * lat)
            nmstrt = 0

            do m=1, ntrunc+1
                do n=m, ntrunc+1
                    nm = nmstrt + n - m + 1

                    !  Compute normalized associate Legendre function at theta
                    call alfk(n - 1, m - 1, cp)
                    call lfpt(n - 1, m - 1, theta, cp, legfunc(nm))

                end do
                nmstrt = nmstrt + ntrunc - m + 2
            end do
        end block

    end subroutine get_legendre_function

    subroutine alfk(n, m, cp)
        ! subroutine alfk (n, m, cp)
        !
        ! dimension of           real cp(n/2 + 1)
        ! arguments
        !
        ! purpose                routine alfk computes double precision fourier
        !                        coefficients in the trigonometric series
        !                        representation of the normalized associated
        !                        legendre function pbar(n, m, theta) for use by
        !                        routines lfp and lfpt in calculating double
        !                        precision pbar(n, m, theta).
        !
        !                        first define the normalized associated
        !                        legendre functions
        !
        !                        pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)
        !                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
        !                        factorial(n)) times the (n+m)th derivative of
        !                        (x**2-1)**n with respect to x=cos(theta)
        !
        !                        where theta is colatitude.
        !
        !                        then subroutine alfk computes the coefficients
        !                        cp(k) in the following trigonometric
        !                        expansion of pbar(m, n, theta).
        !
        !                        1) for n even and m even, pbar(m, n, theta) =
        !                           .5*cp(1) plus the sum from k=1 to k=n/2
        !                           of cp(k+1)*cos(2*k*th)
        !
        !                        2) for n even and m odd, pbar(m, n, theta) =
        !                           the sum from k=1 to k=n/2 of
        !                           cp(k)*sin(2*k*th)
        !
        !                        3) for n odd and m even, pbar(m, n, theta) =
        !                           the sum from k=1 to k=(n+1)/2 of
        !                           cp(k)*cos((2*k-1)*th)
        !
        !                        4) for n odd and m odd,  pbar(m, n, theta) =
        !                           the sum from k=1 to k=(n+1)/2 of
        !                           cp(k)*sin((2*k-1)*th)
        !
        !
        ! usage                  call alfk(n, m, cp)
        !
        ! arguments
        !
        ! on input               n
        !                          nonnegative integer specifying the degree of
        !                          pbar(n, m, theta)
        !
        !                        m
        !                          is the order of pbar(n, m, theta). m can be
        !                          any integer however cp is computed such that
        !                          pbar(n, m, theta) = 0 if abs(m) is greater
        !                          than n and pbar(n, m, theta) = (-1)**m*
        !                          pbar(n, -m, theta) for negative m.
        !
        ! on output              cp
        !                          double precision array of length (n/2)+1
        !                          which contains the fourier coefficients in
        !                          the trigonometric series representation of
        !                          pbar(n, m, theta)
        !
        !
        ! special conditions     none
        !
        ! precision              64-bit double precision
        !
        ! algorithm              the highest order coefficient is determined in
        !                        closed form and the remainig coefficients are
        !                        determined as the solution of a backward
        !                        recurrence relation.
        !
        ! accuracy               comparison between routines alfk and double
        !                        precision dalfk on the cray1 indicates
        !                        greater accuracy for smaller values
        !                        of input parameter n.  agreement to 14
        !                        places was obtained for n=10 and to 13
        !                        places for n=100.
        !

        ! Dummy arguments
        integer(ip), intent(in)   :: n
        integer(ip), intent(in)   :: m
        real(wp),    intent(out)  :: cp(n/2+1)

        ! Local variables
        integer(ip)         :: i, l, ma, nex, nmms2
        real(wp), parameter :: sc10 = 1024.0_wp
        real(wp), parameter :: sc20 = sc10**2
        real(wp), parameter :: sc40 = sc20**2
        real(wp)            :: a1, b1, c1, t1, t2
        real(wp)            :: fk, cp2, pm1
        real(wp)            :: fden, fnmh, fnum, fnnp1, fnmsq

        cp(1) = 0.0_wp
        ma = abs(m)

        if (ma > n) return

        if (n < 1) then
            !
            !  n less than 1
            !
            cp(1) = sqrt(2.0_wp)
        else if (n == 1) then
            !
            !  n equals 1
            !
            if (ma == 0) then
                cp(1) = sqrt(1.5_wp)
            else
                cp(1) = sqrt(0.75_wp)
                select case (m)
                    case (-1)
                        cp(1) = -cp(1)
                end select
            end if
        else
            !
            !  n greater than 1
            !
            select case (mod(n+ma, 2))
                case (0)
                    nmms2 = (n-ma)/2
                    fnum = n+ma+1
                    fnmh = n-ma+1
                    pm1 = 1.0_wp
                case default
                    nmms2 = (n-ma-1)/2
                    fnum = n+ma+2
                    fnmh = n-ma+2
                    pm1 = -1.0_wp
            end select

            t1 = 1.0_wp/sc20
            nex = 20
            fden = 2.0_wp

            if (nmms2 >= 1) then
                do  i=1, nmms2
                    t1 = fnum*t1/fden
                    if (t1 > sc20) then
                        t1 = t1/sc40
                        nex = nex+40
                    end if
                    fnum = fnum+2.0_wp
                    fden = fden+2.0_wp
                end do
            end if

            t1 = t1/2.0_wp**(n-1-nex)

            if (mod(ma/2, 2) /= 0) t1 = -t1

            t2 = 1.0_wp

            if (ma /= 0) then
                do  i=1, ma
                    t2 = fnmh*t2/(fnmh+pm1)
                    fnmh = fnmh+2.0_wp
                end do
            end if

            cp2 = t1*sqrt((real(n, kind=wp)+0.5_wp)*t2)
            fnnp1 = real(n*(n+1), kind=wp)
            fnmsq = fnnp1-2.0_wp*(ma**2)
            l = (n+1)/2

            if (mod(n, 2) == 0 .and. mod(ma, 2) == 0) l = l+1

            cp(l) = cp2

            if ((m < 0) .and. (mod(ma, 2) /= 0)) cp(l) = -cp(l)

            if (l <= 1) return

            fk = n
            a1 = (fk-2.0_wp)*(fk-1.0_wp)-fnnp1
            b1 = 2.0_wp*(fk**2-fnmsq)
            cp(l-1) = b1*cp(l)/a1

            do
                l = l-1

                if (l <= 1) return

                fk = fk-2.0_wp
                a1 = (fk-2.0_wp)*(fk-1.0_wp)-fnnp1
                b1 = -2.0_wp*(fk*fk-fnmsq)
                c1 = (fk+1.0_wp)*(fk+2.0_wp)-fnnp1
                cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
                cycle
            end do
        end if

    end subroutine alfk

    subroutine lfim(init, theta, l, n, nm, pb, id, wlfim)
        !
        ! subroutine lfim (init, theta, l, n, nm, pb, id, wlfim)
        !
        ! dimension of           theta(l),  pb(id, nm+1),  wlfim(4*l*(nm+1))
        ! arguments
        !
        ! purpose                given n and l, routine lfim calculates
        !                        the normalized associated legendre functions
        !                        pbar(n, m, theta) for m=0, ..., n and theta(i)
        !                        for i=1, ..., l where
        !
        !                        pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)
        !                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
        !                        factorial(n)) times the (n+m)th derivative of
        !                        (x**2-1)**n with respect to x=cos(theta)
        !
        ! usage                  call lfim (init, theta, l, n, nm, pb, id, wlfim)
        !
        ! arguments
        ! on input               init
        !                        = 0
        !                            initialization only - using parameters
        !                            l, nm and array theta, subroutine lfim
        !                            initializes array wlfim for subsequent
        !                            use in the computation of the associated
        !                            legendre functions pb. initialization
        !                            does not have to be repeated unless
        !                            l, nm, or array theta are changed.
        !                        = 1
        !                            subroutine lfim uses the array wlfim that
        !                            was computed with init = 0 to compute pb.
        !
        !                        theta
        !                          an array that contains the colatitudes
        !                          at which the associated legendre functions
        !                          will be computed. the colatitudes must be
        !                          specified in radians.
        !
        !                        l
        !                          the length of the theta array. lfim is
        !                          vectorized with vector length l.
        !
        !                        n
        !                          nonnegative integer, less than nm, specifying
        !                          degree of pbar(n, m, theta). subroutine lfim
        !                          must be called starting with n=0. n must be
        !                          incremented by one in subsequent calls and
        !                          must not exceed nm.
        !
        !                        nm
        !                          the maximum value of n and m
        !
        !                        id
        !                          the first dimension of the two dimensional
        !                          array pb as it appears in the program that
        !                          calls lfim. (see output parameter pb)
        !
        !                        wlfim
        !                          an array with length 4*l*(nm+1) which
        !                          must be initialized by calling lfim
        !                          with init=0 (see parameter init)  it
        !                          must not be altered between calls to
        !                          lfim.
        !
        !
        ! on output              pb
        !                          a two dimensional array with first
        !                          dimension id in the program that calls
        !                          lfim. the second dimension of pb must
        !                          be at least nm+1. starting with n=0
        !                          lfim is called repeatedly with n being
        !                          increased by one between calls. on each
        !                          call, subroutine lfim computes
        !                          = pbar(m, n, theta(i)) for m=0, ..., n and
        !                          i=1, ...l.
        !
        !                        wlfim
        !                          array containing values which must not
        !                          be altered unless l, nm or the array theta
        !                          are changed in which case lfim must be
        !                          called with init=0 to reinitialize the
        !                          wlfim array.
        !
        ! special conditions     n must be increased by one between calls
        !                        of lfim in which n is not zero.
        !
        ! precision              64-bit double precision
        !
        !
        ! algorithm              routine lfim calculates pbar(n, m, theta) using
        !                        a four term recurrence relation. (unpublished
        !                        notes by paul n. swarztrauber)
        !

        ! Dummy arguments

        integer(ip), intent(in)  :: init
        real(wp),    intent(in)  :: theta(*)
        integer(ip), intent(in)  :: l
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: nm
        real(wp),    intent(out) :: pb(1)
        integer(ip), intent(in)  :: id
        real(wp),    intent(out) :: wlfim(1)

        ! Local variables

        integer(ip) :: workspace_indices(3)

        !
        !   total length of wlfim is 4*l*(nm+1)
        !
        workspace_indices = get_workspace_indices(l, nm)

        associate (&
            iw1 => workspace_indices(1), &
            iw2 => workspace_indices(2), &
            iw3 => workspace_indices(3) &
            )

            call lfim_lower_utility_routine(init, theta, l, n, nm, id, pb, wlfim, wlfim(iw1), &
                wlfim(iw2), wlfim(iw3), wlfim(iw2))

        end associate

    contains

        pure function get_workspace_indices(l, nm) result (return_value)

            ! Dummy arguments

            integer(ip), intent(in) :: l
            integer(ip), intent(in) :: nm
            integer(ip)              :: return_value(3)

            ! Local variables

            integer(ip) :: lnx

            associate (i => return_value)

                lnx = l*(nm + 1)
                i(1) = lnx + 1
                i(2) = 2*lnx + 1
                i(3) = 3*lnx + 1

            end associate

        end function get_workspace_indices

        subroutine lfim_lower_utility_routine(init, theta, l, n, nm, id, p3, phz, ph1, p1, p2, cp)

            ! Dummy arguments

            integer(ip), intent(in)  :: init
            real(wp),    intent(in)  :: theta(*)
            integer(ip), intent(in)  :: l
            integer(ip), intent(in)  :: n
            integer(ip), intent(in)  :: nm
            integer(ip), intent(in)  :: id
            real(wp),    intent(out) :: p3(id, *)
            real(wp),    intent(out) :: phz(l, *)
            real(wp),    intent(out) :: ph1(l, *)
            real(wp),    intent(out) :: p1(l, *)
            real(wp),    intent(out) :: p2(l, *)
            real(wp),    intent(out) :: cp(*)

            ! Local variables

            integer(ip)         :: i, m, nm1, nh, mp1, np1, nmp1
            real(wp)            :: cc, dd, ee, cn, fm, fn, fnmm, fnpm
            real(wp)            :: tn, temp
            real(wp), parameter :: SQRT2 = sqrt(2.0_wp)
            real(wp), parameter :: SQRT5 = sqrt(5.0_wp)
            real(wp), parameter :: SQRT6 = sqrt(6.0_wp)
            real(wp), parameter :: ONE_OVER_SQRT2 = 1.0_wp/SQRT2
            real(wp), parameter :: ONE_OVER_SQRT6 = 1.0_wp/SQRT6
            real(wp), parameter :: SQRT5_OVER_SQRT6 = SQRT5/SQRT6

            nmp1 = nm+1

            select case (init)
                case (0)
                    phz(:, 1) = ONE_OVER_SQRT2
                    do np1=2, nmp1
                        nh = np1-1
                        call alfk(nh, 0, cp)
                        do i=1, l
                            call lfpt(nh, 0, theta(i), cp, phz(i, np1))
                        end do
                        call alfk(nh, 1, cp)
                        do  i=1, l
                            call lfpt(nh, 1, theta(i), cp, ph1(i, np1))
                        end do
                    end do
                case default
                    if (n <= 2) then
                        if (n < 1) then
                            p3(:, 1) = phz(:, 1)
                        else if (n == 1) then
                            p3(:, 1) = phz(:, 2)
                            p3(:, 2) = ph1(:, 2)
                        else
                            p3(:, 1) = phz(:, 3)
                            p3(:, 2) = ph1(:, 3)
                            p3(:, 3) = SQRT5_OVER_SQRT6 * phz(:, 1) - ONE_OVER_SQRT6 * p3(:, 1)
                            p1(:, 1) = phz(:, 2)
                            p1(:, 2) = ph1(:, 2)
                            p2(:, 1) = phz(:, 3)
                            p2(:, 2) = ph1(:, 3)
                            p2(:, 3) = p3(:, 3)
                        end if
                    else
                        nm1 = n-1
                        np1 = n+1
                        fn = real(n, kind=wp)
                        tn = 2.0_wp*fn
                        cn = (tn+1.0_wp)/(tn-3.0_wp)
                        p3(:, 1) = phz(:, np1)
                        p3(:, 2) = ph1(:, np1)

                        if (nm1 >= 3) then
                            do mp1=3, nm1
                                m = mp1-1
                                fm = real(m, kind=wp)
                                fnpm = fn+fm
                                fnmm = fn-fm
                                temp = fnpm*(fnpm-1.0_wp)
                                cc = sqrt(cn*(fnpm-3.0_wp)*(fnpm-2.0_wp)/temp)
                                dd = sqrt(cn*fnmm*(fnmm-1.0_wp)/temp)
                                ee = sqrt((fnmm+1.0_wp)*(fnmm+2.0_wp)/temp)
                                p3(:, mp1) = cc*p1(i, mp1-2)+dd*p1(:, mp1)-ee*p3(:, mp1-2)
                            end do
                        end if
                        fnpm = 2.0_wp*fn-1.0_wp
                        temp = fnpm*(fnpm-1.0_wp)
                        cc = sqrt(cn*(fnpm-3.0_wp)*(fnpm-2.0_wp)/temp)
                        ee = sqrt(6.0_wp/temp)
                        p3(:, n) = cc*p1(:, n-2)-ee*p3(:, n-2)
                        fnpm = 2.0_wp*fn
                        temp = fnpm*(fnpm-1.0_wp)
                        cc = sqrt(cn*(fnpm-3.0_wp)*(fnpm-2.0_wp)/temp)
                        ee = sqrt(2.0_wp/temp)
                        p3(:, n+1) = cc*p1(:, n-1)-ee*p3(:, n-1)
                        p1(:, 1:np1) = p2(:, 1:np1)
                        p2(:, :np1) = p3(:, 1:np1)
                    end if
            end select

        end subroutine lfim_lower_utility_routine

    end subroutine lfim

    subroutine lfin(init, theta, l, m, nm, pb, id, wlfin)
        !
        ! subroutine lfin (init, theta, l, m, nm, pb, id, wlfin)
        !
        ! dimension of           theta(l),  pb(id, nm+1),  wlfin(4*l*(nm+1))
        ! arguments
        !
        ! purpose                given m and l, routine lfin calculates
        !                        the normalized associated legendre functions
        !                        pbar(n, m, theta) for n=m, ..., nm and theta(i)
        !                        for i=1, ..., l where
        !
        !                        pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)
        !                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
        !                        factorial(n)) times the (n+m)th derivative of
        !                        (x**2-1)**n with respect to x=cos(theta)
        !
        ! usage                  call lfin (init, theta, l, m, nm, pb, id, wlfin)
        !
        ! arguments
        ! on input               init
        !                        = 0
        !                            initialization only - using parameters
        !                            l, nm and the array theta, subroutine lfin
        !                            initializes the array wlfin for subsequent
        !                            use in the computation of the associated
        !                            legendre functions pb. initialization does
        !                            not have to be repeated unless l, nm or
        !                            the array theta are changed.
        !                        = 1
        !                            subroutine lfin uses the array wlfin that
        !                            was computed with init = 0 to compute pb
        !
        !                        theta
        !                          an array that contains the colatitudes
        !                          at which the associated legendre functions
        !                          will be computed. the colatitudes must be
        !                          specified in radians.
        !
        !                        l
        !                          the length of the theta array. lfin is
        !                          vectorized with vector length l.
        !
        !                        m
        !                          nonnegative integer, less than nm, specifying
        !                          degree of pbar(n, m, theta). subroutine lfin
        !                          must be called starting with n=0. n must be
        !                          incremented by one in subsequent calls and
        !                          must not exceed nm.
        !
        !                        nm
        !                          the maximum value of n and m
        !
        !                        id
        !                          the first dimension of the two dimensional
        !                          array pb as it appears in the program that
        !                          calls lfin. (see output parameter pb)
        !
        !                        wlfin
        !                          an array with length 4*l*(nm+1) which
        !                          must be initialized by calling lfin
        !                          with init=0 (see parameter init)  it
        !                          must not be altered between calls to
        !                          lfin.
        !
        !
        ! on output              pb
        !                          a two dimensional array with first
        !                          dimension id in the program that calls
        !                          lfin. the second dimension of pb must
        !                          be at least nm+1. starting with m=0
        !                          lfin is called repeatedly with m being
        !                          increased by one between calls. on each
        !                          call, subroutine lfin computes pb(i, n+1)
        !                          = pbar(m, n, theta(i)) for n=m, ..., nm and
        !                          i=1, ...l.
        !
        !                        wlfin
        !                          array containing values which must not
        !                          be altered unless l, nm or the array theta
        !                          are changed in which case lfin must be
        !                          called with init=0 to reinitialize the
        !                          wlfin array.
        !
        ! special conditions     m must be increased by one between calls
        !                        of lfin in which m is not zero.
        !
        ! precision              single
        !
        ! algorithm              routine lfin calculates pbar(n, m, theta) using
        !                        a four term recurrence relation. (unpublished
        !                        notes by paul n. swarztrauber)
        !

        ! Dummy arguments
        integer(ip), intent(in)  :: init
        real(wp),    intent(in)  :: theta(l)
        integer(ip), intent(in)  :: l
        integer(ip), intent(in)  :: m
        integer(ip), intent(in)  :: nm
        real(wp),    intent(out) :: pb(id, nm+1)
        integer(ip), intent(in)  :: id
        real(wp),    intent(out) :: wlfin(4*l*(nm+1))

        ! Local variables
        integer(ip) :: workspace_indices(3)

        !  total length of wlfin is 4*l*(nm+1)
        workspace_indices = get_workspace_indices(l, nm)

        associate (&
            iw1=> workspace_indices(1), &
            iw2 => workspace_indices(2), &
            iw3 => workspace_indices(3) &
            )
            call lfin_lower_utility_routine(init, theta, l, m, nm, id, pb, wlfin, wlfin(iw1), &
                wlfin(iw2), wlfin(iw3), wlfin(iw2))
        end associate

    contains

        pure function get_workspace_indices(l, nm) result (return_value)

            ! Dummy arguments
            integer(ip), intent(in) :: l
            integer(ip), intent(in) :: nm
            integer(ip)              :: return_value(3)

            ! Local variables
            integer(ip) :: lnx

            associate (i => return_value)
                lnx = l*(nm + 1)
                i(1) = lnx + 1
                i(2) = 2*lnx + 1
                i(3) = 3*lnx + 1
            end associate

        end function get_workspace_indices

        subroutine lfin_lower_utility_routine(init, theta, l, m, nm, id, p3, phz, ph1, p1, p2, cp)

            ! Dummy arguments
            integer(ip), intent(in)  :: init
            real(wp),    intent(in)  :: theta(l)
            integer(ip), intent(in)  :: l
            integer(ip), intent(in)  :: m
            integer(ip), intent(in)  :: nm
            integer(ip), intent(in)  :: id
            real(wp),    intent(out) :: p3(id, *)
            real(wp),    intent(out) :: phz(l, *)
            real(wp),    intent(out) :: ph1(l, *)
            real(wp),    intent(out) :: p1(l, *)
            real(wp),    intent(out) :: p2(l, *)
            real(wp),    intent(out) :: cp(*)

            ! Local variables
            integer(ip)         :: i, n, nh, mp1, np1, mp3, nmp1
            real(wp)            :: cc, dd, ee, cn, fm, fn, fnmm, fnpm
            real(wp)            :: tm, tn, temp
            real(wp), parameter :: SQRT2 = sqrt(2.0_wp)
            real(wp), parameter :: ONE_OVER_SQRT2 = 1.0_wp/sqrt2

            nmp1 = nm+1

            select case (init)
                case (0)

                    phz(:, 1) = ONE_OVER_SQRT2

                    do np1=2, nmp1
                        nh = np1-1
                        call alfk(nh, 0, cp)
                        do i=1, l
                            call lfpt(nh, 0, theta(i), cp, phz(i, np1))
                        end do
                        call alfk(nh, 1, cp)
                        do i=1, l
                            call lfpt(nh, 1, theta(i), cp, ph1(i, np1))
                        end do
                    end do

                case default
                    mp1 = m+1
                    fm = real(m)
                    tm = fm+fm

                    if (m < 1) then

                        p3(:, 1:nmp1) = phz(:, 1:nmp1)
                        p1(:, 1:nmp1) = phz(:, 1:nmp1)

                    else if (m == 1) then

                        p3(:, 2:nmp1) = ph1(:, 2:nmp1)
                        p2(:, 2:nmp1) = ph1(:, 2:nmp1)

                    else
                        temp = tm*(tm-1.0_wp)
                        cc = sqrt((tm+1.0_wp)*(tm-2.0_wp)/temp)
                        ee = sqrt(2.0_wp/temp)
                        p3(:, m+1) = cc*p1(:, m-1)-ee*p1(:, m+1)

                        if (m == nm) return

                        temp = tm*(tm+1.0_wp)
                        cc = sqrt((tm+3.0_wp)*(tm-2.0_wp)/temp)
                        ee = sqrt(6.0_wp/temp)
                        p3(:, m+2) = cc*p1(:, m)-ee*p1(:, m+2)
                        mp3 = m+3

                        if (nmp1 >= mp3) then
                            do np1=mp3, nmp1
                                n = np1-1
                                fn = real(n, kind=wp)
                                tn = fn+fn
                                cn = (tn+1.0_wp)/(tn-3.0_wp)
                                fnpm = fn+fm
                                fnmm = fn-fm
                                temp = fnpm*(fnpm-1.0_wp)
                                cc = sqrt(cn*(fnpm-3.0_wp)*(fnpm-2.0_wp)/temp)
                                dd = sqrt(cn*fnmm*(fnmm-1.0_wp)/temp)
                                ee = sqrt((fnmm+1.0_wp)*(fnmm+2.0_wp)/temp)
                                p3(:, np1) = cc*p1(:, np1-2)+dd*p3(:, np1-2)-ee*p1(:, np1)
                            end do
                        end if

                        p1(:, m:nmp1) = p2(:, m:nmp1)
                        p2(:, m:nmp1) = p3(:, m:nmp1)

                    end if
            end select

        end subroutine lfin_lower_utility_routine

    end subroutine lfin

    subroutine lfp (init, n, m, l, cp, pb, w)
        !
        !
        ! subroutine lfp (init, n, m, l, cp, pb, w)
        !
        ! dimension of           cp((n/2)+1), pb(l), w(5*l+41)
        ! arguments
        !
        ! purpose                routine lfp uses coefficients computed by
        !                        routine alfk to calculate the 64-bit double precision
        !                        normalized associated legendre function pbar(n,
        !                        m, theta) at colatitudes theta=(i-1)*pi/(l-1),
        !                        i=1, ..., l. subroutine lfp evaluates pbar
        !                        using one of the following trigonometric
        !                        expansions
        !
        !                        1) for n even and m even, pbar(m, n, theta) =
        !                           .5*cp(1) plus the sum from k=1 to k=n/2
        !                           of cp(k)*cos(2*k*th)
        !
        !                        2) for n even and m odd, pbar(m, n, theta) =
        !                           the sum from k=1 to k=n/2 of
        !                           cp(k)*sin(2*k*th)
        !
        !                        3) for n odd and m even, pbar(m, n, theta) =
        !                           the sum from k=1 to k=(n+1)/2 of
        !                           cp(k)*cos((2*k-1)*th)
        !
        !                        4) for n odd and m odd,  pbar(m, n, theta) =
        !                           the sum from k=1 to k=(n+1)/2 of
        !                           cp(k)*sin((2*k-1)*th)
        !
        !
        ! usage                  call lfp(init, n, m, l, cp, pb, w)
        !
        ! arguments
        !
        ! on input               init
        !                          = 0 initialization only
        !                          = 1 compute pbar(n, m, theta)
        !
        !                          lfp call with init = 0 initializes array w;
        !                          no values of pbar(n, m, theta) are computed.
        !                          init=0 should be used on the first call, or
        !                          if l or w values differ from those in the
        !                          previous call.
        !
        !                        n
        !                          nonnegative integer, less than l, specifying
        !                          the degree of pbar(n, m, theta)
        !
        !                        m
        !                          is the order of pbar(n, m, theta). m can be
        !                          any integer however pbar(n, m, theta) = 0
        !                          if abs(m) is greater than n and
        !                          pbar(n, m, theta) = (-1)**m*pbar(n, -m, theta)
        !                          for negative m.
        !
        !                        l
        !                          number of colatitudes theta=(i-1)*pi/(l-1)
        !                          for i=1, ..., l where l is greater than 1.
        !                          l must be an odd integer.
        !
        !                        cp
        !                          64-bit double precision array of length (n/2)+1
        !                          containing coefficients computed by routine
        !                          alfk
        !
        !                        w
        !                          a 64-bit double precision work array with at
        !                          least 5*l+41 locations
        !
        ! on output              pb
        !                          64-bit double precision array of length l containing
        !                          pbar(n, m, theta), theta=(i-1)*pi/(l-1) for i=1
        !                          , ..., l.
        !
        !                        w
        !                          a 64-bit double precision array containing values
        !                          which must not be destroyed if the next call
        !                          will have the same value of input parameter n
        !
        ! special conditions     calls to routine lfp must be preceded by an
        !                        appropriate call to routine alfk.
        !
        ! precision              64-bit double precision
        !
        ! algorithm              the trigonometric series formula used by
        !                        routine lfp to calculate pbar(n, m, theta) for
        !                        theta=(i-1)*pi/(l-1), i=1, ..., n, depends on
        !                        m and n as follows:
        !
        !                           1) for n even and m even, the formula is
        !                              .5*cp(1) plus the sum from k=1 to k=n/2
        !                              of cp(k)*cos(2*k*theta)
        !                           2) for n even and m odd. the formula is
        !                              the sum from k=1 to k=n/2 of
        !                              cp(k)*sin(2*k*theta)
        !                           3) for n odd and m even, the formula is
        !                              the sum from k=1 to k=(n+1)/2 of
        !                              cp(k)*cos((2*k-1)*theta)
        !                           4) for n odd and m odd, the formula is
        !                              the sum from k=1 to k=(n+1)/2 of
        !                              cp(k)*sin((2*k-1)*theta)
        !
        ! accuracy               comparison between routines lfp and double
        !                        precision dlfp on the cray1 indicates greater
        !                        accuracy for smaller values of input parameter
        !                        n.  agreement to 12 places was obtained for
        !                        n=10 and to 11 places for n=100.
        !
        ! timing                 time per call to routine lfp is dependent on
        !                        the input parameters l and n.
        !

        ! Dummy arguments

        integer(ip), intent(in)  :: init
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: m
        integer(ip), intent(in)  :: l
        real(wp)                  :: cp(n/2 + 1)
        real(wp)                  :: pb(l)
        real(wp)                  :: w(5*l+41)

        ! Dummy arguments

        integer(ip) :: ma, iw1, iw2

        pb = 0.0_wp

        ma = abs(m)

        if (ma > n) return

        !
        !  Set workspace indices
        !
        iw1 = 2*l+12
        iw2 = iw1+3*(l+1)/2+15

        call lfp_lower_utility_routine(init, n, ma, l, cp, pb, w, w(iw1), w(iw2))

    contains

        subroutine lfp_lower_utility_routine(init, n, m, l, cp, p, wsave1, wsave2, wsave3)

            ! Dummy arguments

            integer(ip), intent(in) :: init
            integer(ip), intent(in) :: n
            integer(ip), intent(in) :: m
            integer(ip), intent(in) :: l
            real(wp)                 :: cp(*)
            real(wp)                 :: p(*)
            real(wp)                 :: wsave1(*)
            real(wp)                 :: wsave2(*)
            real(wp)                 :: wsave3(*)

            ! Local variables
            integer(ip), save   :: lc, lq, ls
            integer(ip)         :: i
            integer(ip)         :: lm1, np1, ls2, kdp, lmi
            real(wp)            :: dt
            real(wp), parameter :: ONE_OVER_SQRT2 = 1.0_wp/sqrt(2.0_wp)
            type(FastFourierTransform)       :: fft

            select case (init)
                case (0)

                    lc=(l+1)/2
                    ls=lc-2
                    lq=lc-1
                    call fft%sinti(ls, wsave1)
                    call fft%costi(lc, wsave2)
                    call fft%cosqi(lq, wsave3)

                case default

                    if ((n <= 0) .and. (m <= 0)) then
                        p(1:l) = ONE_OVER_SQRT2
                    else
                        ls2 = (l+1)/2
                        lm1 = l-1
                        np1 = n+1

                        dt = PI/lm1

                        if (mod(n, 2) <= 0) then
                            if (mod(m, 2) <= 0) then
                                kdp = n/2+1
                                p(1:kdp)=0.5_wp*cp(1:kdp)
                                p(lc)= 2.0_wp*p(lc)

                                call fft%cost(lc, p, wsave2)

                                do i=1, lc
                                    lmi=l-i
                                    p(lmi+1)=p(i)
                                end do
                            else
                                kdp=n/2
                                p(2:kdp+1)=0.5_wp*cp(1:kdp)
                                p(ls+2)=0.0_wp

                                call fft%sint(ls, p(2), wsave1)

                                do i=1, ls
                                    lmi=l-i
                                    p(lmi)=-p(i+1)
                                end do

                                p(l)=0.0_wp
                            end if
                        else
                            kdp=(n+1)/2

                            if (mod(m, 2) <= 0) then

                                p(1:kdp)=0.25_wp*cp(1:kdp)

                                call fft%cosqb(lq, p, wsave3)

                                do i=1, lq
                                    lmi=l-i
                                    p(lmi+1)=-p(i)
                                end do

                            else
                                p(2:kdp+1)=0.25_wp*cp(1:kdp)

                                call fft%sinqb(lq, p(2), wsave3)

                                do i=1, lq
                                    lmi=l-i
                                    p(lmi)=p(i+1)
                                end do

                                p(l)=0.0_wp
                            end if
                        end if
                    end if
            end select

        end subroutine lfp_lower_utility_routine

    end subroutine lfp

    subroutine lfpt(n, m, theta, cp, pb)
        !
        ! subroutine lfpt (n, m, theta, cp, pb)
        !
        ! dimension of
        ! arguments
        !                        cp((n/2)+1)
        !
        ! purpose                routine lfpt uses coefficients computed by
        !                        routine alfk to compute the single precision
        !                        normalized associated legendre function pbar(n,
        !                        m, theta) at colatitude theta.
        !
        ! usage                  call lfpt(n, m, theta, cp, pb)
        !
        ! arguments
        !
        ! on input               n
        !                          nonnegative integer specifying the degree of
        !                          pbar(n, m, theta)
        !                        m
        !                          is the order of pbar(n, m, theta). m can be
        !                          any integer however pbar(n, m, theta) = 0
        !                          if abs(m) is greater than n and
        !                          pbar(n, m, theta) = (-1)**m*pbar(n, -m, theta)
        !                          for negative m.
        !
        !                        theta
        !                          single precision colatitude in radians
        !
        !                        cp
        !                          single precision array of length (n/2)+1
        !                          containing coefficients computed by routine
        !                          alfk
        !
        ! on output              pb
        !                          single precision variable containing
        !                          pbar(n, m, theta)
        !
        ! special conditions     calls to routine lfpt must be preceded by an
        !                        appropriate call to routine alfk.
        !
        ! precision              single
        !
        ! algorithm              the trigonometric series formula used by
        !                        routine lfpt to calculate pbar(n, m, th) at
        !                        colatitude th depends on m and n as follows:
        !
        !                           1) for n even and m even, the formula is
        !                              .5*cp(1) plus the sum from k=1 to k=n/2
        !                              of cp(k)*cos(2*k*th)
        !                           2) for n even and m odd. the formula is
        !                              the sum from k=1 to k=n/2 of
        !                              cp(k)*sin(2*k*th)
        !                           3) for n odd and m even, the formula is
        !                              the sum from k=1 to k=(n+1)/2 of
        !                              cp(k)*cos((2*k-1)*th)
        !                           4) for n odd and m odd, the formula is
        !                              the sum from k=1 to k=(n+1)/2 of
        !                              cp(k)*sin((2*k-1)*th)
        !
        ! accuracy               comparison between routines lfpt and double
        !                        precision dlfpt on the cray1 indicates greater
        !                        accuracy for greater values on input parameter
        !                        n.  agreement to 13 places was obtained for
        !                        n=10 and to 12 places for n=100.
        !
        ! timing                 time per call to routine lfpt is dependent on
        !                        the input parameter n.
        !

        ! Dummy arguments

        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: m
        real(wp),    intent(in)  :: theta
        real(wp),    intent(in)  :: cp(n/2+1)
        real(wp),    intent(out) :: pb

        ! Local variables

        integer(ip) :: ma, np1, k, kdo, kp1
        real(wp)    :: cos2t, sin2t, cost, sint, temp, summation

        pb = 0.0_wp
        ma = abs(m)

        if (ma <= n) then
            if (n <= 0) then
                if (ma <= 0) pb= sqrt(0.5_wp)
            else
                np1 = n+1
                if (mod(n, 2) <= 0) then
                    if (mod(ma, 2) <= 0) then
                        kdo = n/2+1
                        cos2t = cos(2.0_wp*theta)
                        sin2t = sin(2.0_wp*theta)
                        cost = 1.0_wp
                        sint = 0.0_wp
                        summation = 0.5_wp * cp(1)

                        do kp1=2, kdo
                            temp = cos2t*cost-sin2t*sint
                            sint = sin2t*cost+cos2t*sint
                            cost = temp
                            summation = summation+cp(kp1)*cost
                        end do

                        pb = summation
                    else
                        kdo = n/2
                        cos2t = cos(2.0_wp*theta)
                        sin2t = sin(2.0_wp*theta)
                        cost = 1.0_wp
                        sint = 0.0_wp
                        summation = 0.0_wp

                        do k=1, kdo
                            temp = cos2t*cost-sin2t*sint
                            sint = sin2t*cost+cos2t*sint
                            cost = temp
                            summation = summation+cp(k)*sint
                        end do

                        pb = summation
                    end if
                else
                    kdo = (n+1)/2
                    if (mod(ma, 2) <= 0) then
                        cos2t = cos(2.0*theta)
                        sin2t = sin(2.0*theta)
                        cost = cos(theta)
                        sint = -sin(theta)
                        summation = 0.0_wp

                        do k=1, kdo
                            temp = cos2t*cost-sin2t*sint
                            sint = sin2t*cost+cos2t*sint
                            cost = temp
                            summation = summation+cp(k)*cost
                        end do

                        pb= summation
                    else
                        cos2t = cos(2.0*theta)
                        sin2t = sin(2.0*theta)
                        cost = cos(theta)
                        sint = -sin(theta)
                        summation = 0.0_wp

                        do k=1, kdo
                            temp = cos2t*cost-sin2t*sint
                            sint = sin2t*cost+cos2t*sint
                            cost = temp
                            summation = summation+cp(k)*sint
                        end do

                        pb = summation
                    end if
                end if
            end if
        end if

    end subroutine lfpt

end module type_AssociatedLegendrePolynomialGenerator


C $Id$
      SUBROUTINE ECP_GAUSSQ(KIND, N, ALPHA, BETA, KPTS, ENDPTS, B, T, W)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION MUZERO
C
C           THIS SET OF ROUTINES COMPUTES THE NODES X(I) AND WEIGHTS
C        C(I) FOR GAUSSIAN-TYPE QUADRATURE RULES WITH PRE-ASSIGNED
C        NODES.  THESE ARE USED WHEN ONE WISHES TO APPROXIMATE
C
C                 INTEGRAL (FROM A TO B)  F(X) W(X) DX
C
C                              N
C        BY                   SUM C  F(X )
C                             I=1  I    I
C
C        HERE W(X) IS ONE OF SIX POSSIBLE NON-NEGATIVE WEIGHT
C        FUNCTIONS (LISTED BELOW), AND F(X) IS THE
C        FUNCTION TO BE INTEGRATED.  GAUSSIAN QUADRATURE IS PARTICULARLY
C        USEFUL ON INFINITE INTERVALS (WITH APPROPRIATE WEIGHT
C        FUNCTIONS), SINCE THEN OTHER TECHNIQUES OFTEN FAIL.
C
C           ASSOCIATED WITH EACH WEIGHT FUNCTION W(X) IS A SET OF
C        ORTHOGONAL POLYNOMIALS.  THE NODES X(I) ARE JUST THE ZEROES
C        OF THE PROPER N-TH DEGREE POLYNOMIAL.
C
C     INPUT PARAMETERS
C
C        KIND     AN INTEGER BETWEEN 1 AND 6 GIVING THE TYPE OF
C                 QUADRATURE RULE
C
C        KIND = 1=  LEGENDRE QUADRATURE, W(X) = 1 ON (-1, 1)
C        KIND = 2=  CHEBYSHEV QUADRATURE OF THE FIRST KIND
C                   W(X) = 1/SQRT(1 - X*X) ON (-1, +1)
C        KIND = 3=  CHEBYSHEV QUADRATURE OF THE SECOND KIND
C                   W(X) = SQRT(1 - X*X) ON (-1, 1)
C        KIND = 4=  HERMITE QUADRATURE, W(X) = EXP(-X*X) ON
C                   (-INFINITY, +INFINITY)
C        KIND = 5=  JACOBI QUADRATURE, W(X) = (1-X)**ALPHA * (1+X)**
C                   BETA ON (-1, 1), ALPHA, BETA .GT. -1.
C                   NOTE= KIND=2 AND 3 ARE A SPECIAL CASE OF THIS.
C        KIND = 6=  GENERALIZED LAGUERRE QUADRATURE, W(X) = EXP(-X)*
C                   X**ALPHA ON (0, +INFINITY), ALPHA .GT. -1
C
C        N        THE NUMBER OF POINTS USED FOR THE QUADRATURE RULE
C        ALPHA    DOUBLE PRECISION PARAMETER USED ONLY FOR GAUSS-JACOBI
C                 AND GAUSS-LAGUERRE QUADRATURE (OTHERWISE USE 0.).
C        BETA     DOUBLE PRECISION PARAMETER USED ONLY FOR GAUSS-JACOBI
C                 QUADRATURE (OTHERWISE USE 0.).
C        KPTS     (INTEGER) NORMALLY 0, UNLESS THE LEFT OR RIGHT END-
C                 POINT (OR BOTH) OF THE INTERVAL IS REQUIRED TO BE A
C                 NODE (THIS IS CALLED GAUSS-RADAU OR GAUSS-LOBATTO
C                 QUADRATURE).  THEN KPTS IS THE NUMBER OF FIXED
C                 ENDPOINTS (1 OR 2).
C        ENDPTS   DOUBLE PRECISION ARRAY OF LENGTH 2.  CONTAINS THE
C                 VALUES OF ANY FIXED ENDPOINTS, IF KPTS = 1 OR 2.
C        B        DOUBLE PRECISION SCRATCH ARRAY OF LENGTH N
C
C     OUTPUT PARAMETERS (BOTH ARRAYS OF LENGTH N)
C
C        T        WILL CONTAIN THE DESIRED NODES X(1),,,X(N)
C        W        WILL CONTAIN THE DESIRED WEIGHTS C(1),,,C(N)
C
C     SUBROUTINES REQUIRED
C
C        GBSLVE, CLASS, AND GBTQL2 ARE PROVIDED. UNDERFLOW MAY SOMETIMES
C        OCCUR, BUT IT IS HARMLESS IF THE UNDERFLOW INTERRUPTS ARE
C        TURNED OFF AS THEY ARE ON THIS MACHINE.
C
C     ACCURACY
C
C        THE ROUTINE WAS TESTED UP TO N = 512 FOR LEGENDRE QUADRATURE,
C        UP TO N = 136 FOR HERMITE, UP TO N = 68 FOR LAGUERRE, AND UP
C        TO N = 10 OR 20 IN OTHER CASES.  IN ALL BUT TWO INSTANCES,
C        COMPARISON WITH TABLES IN REF. 3 SHOWED 12 OR MORE SIGNIFICANT
C        DIGITS OF ACCURACY.  THE TWO EXCEPTIONS WERE THE WEIGHTS FOR
C        HERMITE AND LAGUERRE QUADRATURE, WHERE UNDERFLOW CAUSED SOME
C        VERY SMALL WEIGHTS TO BE SET TO ZERO.  THIS IS, OF COURSE,
C        COMPLETELY HARMLESS.
C
C     METHOD
C
C           THE COEFFICIENTS OF THE THREE-TERM RECURRENCE RELATION
C        FOR THE CORRESPONDING SET OF ORTHOGONAL POLYNOMIALS ARE
C        USED TO FORM A SYMMETRIC TRIDIAGONAL MATRIX, WHOSE
C        EIGENVALUES (DETERMINED BY THE IMPLICIT QL-METHOD WITH
C        SHIFTS) ARE JUST THE DESIRED NODES.  THE FIRST COMPONENTS OF
C        THE ORTHONORMALIZED EIGENVECTORS, WHEN PROPERLY SCALED,
C        YIELD THE WEIGHTS.  THIS TECHNIQUE IS MUCH FASTER THAN USING A
C        ROOT-FINDER TO LOCATE THE ZEROES OF THE ORTHOGONAL POLYNOMIAL.
C        FOR FURTHER DETAILS, SEE REF. 1.  REF. 2 CONTAINS DETAILS OF
C        GAUSS-RADAU AND GAUSS-LOBATTO QUADRATURE ONLY.
C
C     REFERENCES
C
C        1.  GOLUB, G. H., AND WELSCH, J. H.,  CALCULATION OF GAUSSIAN
C            QUADRATURE RULES,  MATHEMATICS OF COMPUTATION 23 (APRIL,
C            1969), PP. 221-230.
C        2.  GOLUB, G. H.,  SOME MODIFIED MATRIX EIGENVALUE PROBLEMS,
C            SIAM REVIEW 15 (APRIL, 1973), PP. 318-334 (SECTION 7).
C        3.  STROUD AND SECREST, GAUSSIAN QUADRATURE FORMULAS, PRENTICE-
C            HALL, ENGLEWOOD CLIFFS, N.J., 1966.
C
C     ..................................................................
C
      DIMENSION  B(N),T(N),W(N),ENDPTS(2)
C
      CALL ECP_CLASS (KIND, N, ALPHA, BETA, B, T, MUZERO)
C
C           THE MATRIX OF COEFFICIENTS IS ASSUMED TO BE SYMMETRIC.
C           THE ARRAY T CONTAINS THE DIAGONAL ELEMENTS, THE ARRAY
C           B THE OFF-DIAGONAL ELEMENTS.
C           MAKE APPROPRIATE CHANGES IN THE LOWER RIGHT 2 BY 2
C           SUBMATRIX.
C
      IF (KPTS.EQ.0)  GO TO 100
      IF (KPTS.EQ.2)  GO TO  50
C
C           IF KPTS=1, ONLY T(N) MUST BE CHANGED
C
      T(N) =ECP_GBSLVE(ENDPTS(1),N,T,B)*B(N-1)**2 + ENDPTS(1)
      GO TO 100
C
C           IF KPTS=2, T(N) AND B(N-1) MUST BE RECOMPUTED
C
   50 GAM =ECP_GBSLVE(ENDPTS(1),N,T,B)
      T1 = ((ENDPTS(1) - ENDPTS(2))/(ECP_GBSLVE(ENDPTS(2),N,T,B) - GAM))
      B(N-1) =  SQRT(T1)
      T(N) = ENDPTS(1) + GAM*T1
C
C           NOTE THAT THE INDICES OF THE ELEMENTS OF B RUN FROM 1 TO N-1
C           AND THUS THE VALUE OF B(N) IS ARBITRARY.
C           NOW COMPUTE THE EIGENVALUES OF THE SYMMETRIC TRIDIAGONAL
C           MATRIX, WHICH HAS BEEN MODIFIED AS NECESSARY.
C           THE METHOD USED IS A QL-TYPE METHOD WITH ORIGIN SHIFTING
C
  100 W(1) = 1.0d00
      DO 105 I = 2, N
  105    W(I) = 0.0d00
C
      CALL ECP_GBTQL2 (N, T, B, W, IERR)
      DO 110 I = 1, N
  110    W(I) = MUZERO * W(I) * W(I)
C
      RETURN
      END
C
C
C
      DOUBLE PRECISION FUNCTION ECP_GBSLVE(SHIFT, N, A, B)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ONE = 1.0d00)
C
C       THIS PROCEDURE PERFORMS ELIMINATION TO SOLVE FOR THE
C       N-TH COMPONENT OF THE SOLUTION DELTA TO THE EQUATION
C
C             (JN - SHIFT*IDENTITY) * DELTA  = EN,
C
C       WHERE EN IS THE VECTOR OF ALL ZEROES EXCEPT FOR 1 IN
C       THE N-TH POSITION.
C
C       THE MATRIX JN IS SYMMETRIC TRIDIAGONAL, WITH DIAGONAL
C       ELEMENTS A(I), OFF-DIAGONAL ELEMENTS B(I).  THIS EQUATION
C       MUST BE SOLVED TO OBTAIN THE APPROPRIATE CHANGES IN THE LOWER
C       2 BY 2 SUBMATRIX OF COEFFICIENTS FOR ORTHOGONAL POLYNOMIALS.
C
C
      DIMENSION  A(N),B(N)
C
      ALPHA = A(1) - SHIFT
      NM1 = N - 1
      DO 10 I = 2, NM1
   10    ALPHA = A(I) - SHIFT - B(I-1)**2/ALPHA
      ECP_GBSLVE = ONE/ALPHA
      RETURN
      END
C
C
C
      SUBROUTINE ECP_CLASS(KIND, N, ALPHA, BETA, B, A, MUZERO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION  MUZERO
C
C           THIS PROCEDURE SUPPLIES THE COEFFICIENTS A(J), B(J) OF THE
C        RECURRENCE RELATION
C
C             B P (X) = (X - A ) P   (X) - B   P   (X)
C              J J            J   J-1       J-1 J-2
C
C        FOR THE VARIOUS CLASSICAL (NORMALIZED) ORTHOGONAL POLYNOMIALS,
C        AND THE ZERO-TH MOMENT
C
C             MUZERO = INTEGRAL W(X) DX
C
C        OF THE GIVEN POLYNOMIAL   WEIGHT FUNCTION W(X).  SINCE THE
C        POLYNOMIALS ARE ORTHONORMALIZED, THE TRIDIAGONAL MATRIX IS
C        GUARANTEED TO BE SYMMETRIC.
C
C           THE INPUT PARAMETER ALPHA IS USED ONLY FOR LAGUERRE AND
C        JACOBI POLYNOMIALS, AND THE PARAMETER BETA IS USED ONLY FOR
C        JACOBI POLYNOMIALS.  THE LAGUERRE AND JACOBI POLYNOMIALS
C        REQUIRE THE GAMMA FUNCTION.
C
C     ..................................................................
C
      DIMENSION  A(N),B(N)
      PARAMETER (ZERO = 0.0d00, ONE = 1.0d00, TWO = 2.0d00)
      PARAMETER (FOUR = 4.0d00, HALF = ONE/TWO)
C
      PI = FOUR*ATAN(ONE)
      NM1 = N - 1
      GO TO (10, 20, 30, 40, 50, 60), KIND
C
C              KIND = 1=  LEGENDRE POLYNOMIALS P(X)
C              ON (-1, +1), W(X) = 1.
C
   10 MUZERO = TWO
      DO 11 I = 1, NM1
         A(I) = ZERO
         ABI = I
   11    B(I) = ABI/ SQRT(4*ABI*ABI - ONE  )
      A(N) = ZERO
      RETURN
C
C              KIND = 2=  CHEBYSHEV POLYNOMIALS OF THE FIRST KIND T(X)
C              ON (-1, +1), W(X) = 1 / SQRT(1 - X*X)
C
   20 MUZERO = PI
      DO 21 I = 1, NM1
         A(I) = ZERO
   21    B(I) = HALF
      B(1) =  SQRT(HALF  )
      A(N) = ZERO
      RETURN
C
C              KIND = 3=  CHEBYSHEV POLYNOMIALS OF THE SECOND KIND U(X)
C              ON (-1, +1), W(X) = SQRT(1 - X*X)
C
   30 MUZERO = PI/TWO
      DO 31 I = 1, NM1
         A(I) = ZERO
   31    B(I) = HALF
      A(N) = ZERO
      RETURN
C
C              KIND = 4=  HERMITE POLYNOMIALS H(X) ON (-INFINITY,
C              +INFINITY), W(X) = EXP(-X**2)
C
   40 MUZERO =  SQRT(PI)
      DO 41 I = 1, NM1
         A(I) = ZERO
   41    B(I) =  SQRT(I/TWO  )
      A(N) = ZERO
      RETURN
C
C              KIND = 5=  JACOBI POLYNOMIALS P(ALPHA, BETA)(X) ON
C              (-1, +1), W(X) = (1-X)**ALPHA + (1+X)**BETA, ALPHA AND
C              BETA GREATER THAN -1
C
   50 AB = ALPHA + BETA
      ABI = TWO + AB
      MUZERO = TWO ** (AB + ONE) * ECP_DGAMMA(ALPHA + ONE) *
     X ECP_DGAMMA(BETA + ONE) / ECP_DGAMMA(ABI)
      A(1) = (BETA - ALPHA)/ABI
      B(1) =  SQRT(FOUR*(ONE+ALPHA)*(ONE+BETA)/((ABI+ONE)*ABI*ABI))
      A2B2 = BETA*BETA - ALPHA*ALPHA
      DO 51 I = 2, NM1
         DI = I
         ABI = TWO  *DI + AB
         A(I) = A2B2/((ABI - TWO  )*ABI)
   51    B(I) =  SQRT (FOUR*DI*(DI + ALPHA)*(DI + BETA)*(DI + AB)/
     1   ((ABI*ABI - ONE)*ABI*ABI))
      ABI = TWO *N + AB
      A(N) = A2B2/((ABI - TWO  )*ABI)
      RETURN
C
C              KIND = 6=  LAGUERRE POLYNOMIALS L(ALPHA)(X) ON
C              (0, +INFINITY), W(X) = EXP(-X) * X**ALPHA, ALPHA GREATER
C              THAN -1.
C
   60 MUZERO = ECP_DGAMMA(ALPHA + ONE)
      DO 61 I = 1, NM1
         A(I) = TWO  *I - ONE   + ALPHA
   61    B(I) =  SQRT(I*(I + ALPHA))
      A(N) = TWO  *N - 1 + ALPHA
      RETURN
      END
C     ------------------------------------------------------------------
C
      SUBROUTINE ECP_GBTQL2(N, D, E, Z, IERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION  MACHEP
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND FIRST COMPONENTS OF THE
C     EIGENVECTORS OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL
C     METHOD, AND IS ADAPTED FROM THE EISPAK ROUTINE IMTQL2
C
C     ON INPUT=
C
C        N IS THE ORDER OF THE MATRIX;
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX;
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS FIRST N-1 POSITIONS.  E(N) IS ARBITRARY;
C
C        Z CONTAINS THE FIRST ROW OF THE IDENTITY MATRIX.
C
C      ON OUTPUT=
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1, 2, ..., IERR-1;
C
C        E HAS BEEN DESTROYED;
C
C        Z CONTAINS THE FIRST COMPONENTS OF THE ORTHONORMAL EIGENVECTORS
C          OF THE SYMMETRIC TRIDIAGONAL MATRIX.  IF AN ERROR EXIT IS
C          MADE, Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES;
C
C        IERR IS SET TO
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ------------------------------------------------------------------
C
      INTEGER I, J, K, L, M, N, II, MML, IERR
      DIMENSION  D(N),E(N),Z(N)
      double precision dlamch
      external dlamch
      PARAMETER (ZERO = 0.0d00, ONE = 1.0d00, TWO = 2.0d00)
      PARAMETER (FOUR = 4.0d00, HALF = ONE/TWO)
C
C     ========== MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C                MACHEP = 16.0D0**(-13) FOR LONG FORM ARITHMETIC
C                ON S360 ==========
c     inverse of the square root of the overflow
       machep=1d0/sqrt(dlamch('o'))
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      E(N) = ZERO
      DO 240 L = 1, N
         J = 0
C     ========== LOOK FOR SMALL SUB-DIAGONAL ELEMENT ==========
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            IF ( ABS(E(M)) .LE. MACHEP * ( ABS(D(M)) +  ABS(D(M+1))))
     X         GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ========== FORM SHIFT ==========
         G = (D(L+1) - P) / (TWO   * E(L))
         R =  SQRT(G*G+ONE  )
         G = D(M) - P + E(L) / (G +  SIGN(R, G))
         S = ONE
         C = ONE
         P = ZERO
         MML = M - L
C     ========== FOR I=M-1 STEP -1 UNTIL L DO -- ==========
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF ( ABS(F) .LT.  ABS(G)) GO TO 150
            C = G / F
            R =  SQRT(C*C+ONE  )
            E(I+1) = F * R
            S = ONE   / R
            C = C * S
            GO TO 160
  150       S = F / G
            R =  SQRT(S*S+ONE  )
            E(I+1) = G * R
            C = ONE   / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + TWO   * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
C     ========== FORM FIRST COMPONENT OF VECTOR ==========
            F = Z(I+1)
            Z(I+1) = S * Z(I) + C * F
            Z(I) = C * Z(I) - S * F
C
  200    CONTINUE
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = ZERO
         GO TO 105
  240 CONTINUE
C     ========== ORDER EIGENVALUES AND EIGENVECTORS ==========
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         P = Z(I)
         Z(I) = Z(K)
         Z(K) = P
C
  300 CONTINUE
C
      GO TO 1001
C     ========== SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ==========
 1000 IERR = L
 1001 RETURN
C     ========== LAST CARD OF GBTQL2 ==========
      END
      double precision FUNCTION  ECP_DGAMMA(ZZ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     MODIFIED 4/4/88 BY DWS TO BE ACCURATE FOR ZZ GT 3.
C  THIS IS A PROCEDURE THAT EVALUATES GAMMA(Z) FOR
C     0 LT Z LE 3 TO 16 SIGNIFICANT FIGURES
C    IT IS BASED ON A CHEBYSHEV-TYPE POLYNOMIAL
C   APPROXIMATION GIVEN IN H. WERNER AND R. COLLINGE, MATH. COMPUT.
C    15 (1961), PP. 195-97.
C   APPROXIMATIONS TO THE GAMMA FUNCTION, ACCURATE UP TO 18 SIGNIFICANT
C   DIGITS, MAY BE FOUND IN THE PAPER QUOTED ABOVE
C
C
C
      DIMENSION  A(18)
      PREFAC=1.0D0
      Z=ZZ
   44 CONTINUE
      IF(Z.LT.3.0D0)GO TO 45
      Z=Z-1.0D0
      PREFAC=PREFAC*Z
      GO TO 44
   45 CONTINUE
C
      A(1)=1.0D0
      A(2)=.4227843350984678D0
      A(3)=.4118403304263672D0
      A(4)=.0815769192502609D0
      A(5)=.0742490106800904D0
      A(6)=-.0002669810333484D0
      A(7)=.0111540360240344D0
      A(8)=-.0028525821446197D0
      A(9)=.0021036287024598D0
      A(10)=-.0009184843690991D0
      A(11)=.0004874227944768D0
      A(12)=-.0002347204018919D0
      A(13)=.0001115339519666D0
      A(14)=-.0000478747983834D0
      A(15)=.0000175102727179D0
      A(16)=-.0000049203750904D0
      A(17)=.0000009199156407D0
      A(18)=-.0000000839940496D0
C
C
C
      IF(Z.LE.1.0D0  ) GO TO 10
      IF(Z.LE.2.0D0  ) GO TO 20
      T=Z-2.0D0
      GO TO 30
10    T=Z
      GO TO 30
20    T=Z-1.0D0
30    P=A(18)
      DO 40 K=17,1,-1
        P=T*P+A(K)
   40 CONTINUE
C
      P=P*PREFAC
      IF(Z.GT.2.0D0  ) GO TO 50
      IF(Z.GT.1.0D0  ) GO TO 60
      ECP_DGAMMA=P/(Z*(Z+1.0D0  ))
      RETURN
60    ECP_DGAMMA=P/Z
      RETURN
50    ECP_DGAMMA=P
      RETURN
      END


      SUBROUTINE KENDL1(DATA1,DATA2,N,TAU,Z,PROB)
      DIMENSION DATA1(N),DATA2(N)
      N1=0
      N2=0
      IS=0
      DO 12 J=1,N-1
        DO 11 K=J+1,N
          A1=DATA1(J)-DATA1(K)
          A2=DATA2(J)-DATA2(K)
          AA=A1*A2
          IF(AA.NE.0.)THEN
            N1=N1+1
            N2=N2+1
            IF(AA.GT.0.)THEN
              IS=IS+1
            ELSE
              IS=IS-1
            ENDIF
          ELSE
            IF(A1.NE.0.)N1=N1+1
            IF(A2.NE.0.)N2=N2+1
          ENDIF
11      CONTINUE
12    CONTINUE
      TAU=FLOAT(IS)/SQRT(FLOAT(N1)*FLOAT(N2))
      VAR=(4.*N+10.)/(9.*N*(N-1.))
      Z=TAU/SQRT(VAR)
      PROB=ERFCC(ABS(Z)/1.4142136)
      RETURN
      END


subroutine getuu

! generates a matrix (uu, stored in the share module) with nov columns and
! m=product(abs(indini)) rows which can be used to transform nov nested loops into
! a single loop
!
! e.g. for nov=3 and indini=(2,2,4)
! do i=0,1
!	do j=0,1
!		do k=0,3
!			write(*,*)i,j,k
!		enddo
!	enddo
! enddo
!
! is equivalent to
! do i=1,16
!	write(*,*)uu(1,i),uu(2,i),uu(3,i)
! enddo
!

use share, only: dp,nov,indini,uu

implicit none

integer	    ::	i,j,k,nr,nrd,c1,c2
integer     ::  pindi ! product(abs(indini(1:nov)))
integer	    ::  istat !allocate status var

pindi=product(abs(indini(1:nov)))
if (allocated(uu)) deallocate(uu)
allocate (uu(nov,pindi),stat=istat)
call checkstat(istat,'uu')

do i=1,nov
	c1=1
        nr=pindi
	!write(*,*)'nr=',nr
	do k=1,pindi/nr
		c2=1
		nrd=nr/abs(indini(i))
		do j=1,nr
			uu(i,c1)=(c2-1)/nrd
			!write(*,*)'i,c1,uu(i,c1),c2',i,c1,uu(i,c1),c2
			c1=c1+1
			c2=c2+1
		enddo
	enddo
enddo

end subroutine getuu


!----------------------------------------------------------------------------- best with 100 columns

function polyX1()
  use modPolyX
  integer polyX1
  type(polyX)::a

  polyX1=0
  call a%init(4,1,4)
  a%pN(:,1)=[0d0,0d0,0d0]
  a%pN(:,2)=[1d0,0d0,0d0]
  a%pN(:,3)=[0d0,2d0,0d0]
  a%pN(:,4)=[0d0,0d0,3d0]
  a%nNE(1)=4
  a%iNE(:,1)=[1,2,3,4]
  call a%up()
  if(norm2(a%p(:,1)-[0.25d0,0.5d0,0.75d0])>tiny(1d0))then
    polyX1=polyX1+1
  end if
  call a%clear()
end function


! **************************************************************************
! ... cost.f90
! ... Quim Ballabrera, January 2018
! ...
! ... System Dynamics
! ... Adjoint methods applied to the Lorenz model
! ...
! ... The FUNCTION JCOST calculates the cost function:
! ...
! ...            Jcost = 1/2 * Sum_i=1^p  [y^o(t_i) - M(xo,to,ti)]^2
! ...
! ... as a function of the intial condition, xo.
! ...
! ... The subroutine runs the lorenz model and accounts for the
! ... difference against observations.
! ...
! ... The SUBROUTINE DCOST calculates the derivative of the cost function
! ... by respect the initial conditions:
! ...
! ...                         DCOST(i) = d Jcost / d xo(i)
! ...
! ... by using the adjoint of the Lorenz model.
! ...
! **************************************************************************

real(dp) function Jcost (xo)

use sysdyn
use adjoint

implicit none

real(dp), dimension(NVE), intent(in)          :: xo

! ... Local variables:
! ...
integer i,step,nsteps,ncount
real(dp) to,tf,dt,t,innov,Jb
real(dp), dimension(NVE)                      :: x,xn,dd

! ... Model time interval:
! ...
dt = lorenz_dt
to = cost_to
tf = cost_tf
nsteps = nint((tf-to)/dt)

if (verbose) then
  write(*,*)
  write(*,*) '== COST FUNCTION == '
  write(*,*) 'Initial time  = ', to
  write(*,*) 'Final   time  = ', tf
  write(*,*) 'Time interval = ', dt
  write(*,*) 'Model steps   = ', nsteps
endif

! ... Find the index:
! ...
do step=1,obs%Nobs
  if ((obs%time(step).ge.to).or. &
      (abs(obs%time(step)-to).lt.0.01*dt)) then
    obs%p = step
    exit
  endif
enddo

! ... Evaluate cost function:
! ...
Jcost = zero
ncount = 0

! ... Initial condition contribution
! ...
if (abs(obs%time(obs%p)-to).lt.0.01*dt) then
  if (verbose) write(*,*) 'Cost contribution, time = ', to
  do i=1,NVE
    if (obs%iobs(i).eq.1) then
      innov  = obs%y(i,obs%p) - xo(i)
      Jcost  = Jcost  + innov*innov/r2(i)
      ncount = ncount + 1
    endif
  enddo
  obs%p = obs%p + 1
endif

! ... Background field:
! ...
if (alpha.ge.1.d-8) then
  dd = xb(:) - xo(:)
  xn = MATMUL(Binv,dd)
  Jb = alpha*DOT_PRODUCT(dd,xn)
  if (verbose) write(*,*) 'Adding Background term', Jb
  Jcost = Jcost + Jb
endif

! ... Now run the model
! ...
x = xo
t = to
do step=1,nsteps

  call rk4 (lorenz_n,x,t,dt,xn,lorenz_rhs)
  x(:) = xn(:)
  t    = t + dt

  if (obs%p.le.obs%Nobs) then
    if (step.eq.obs%step(obs%p)) then
      !print*, 'Cost contribution, time = ', t
      do i=1,NVE
        if (obs%iobs(i).eq.1) then
          innov  = obs%y(i,obs%p) - x(i)
          Jcost  = Jcost  + innov*innov/r2(i)
          ncount = ncount + obs%iobs(i)
        endif
      enddo
      obs%p = obs%p + 1
    endif
  endif

enddo

if (verbose) then
  write(*,*) 'Number observ = ', ncount
endif

Jcost = half * Jcost

end function Jcost
! ...
! =================================================================================
! ...
subroutine dCost (xo,gradx)

use sysdyn
use adjoint

implicit none

real(dp), dimension(NVE), intent(in)          :: xo
real(dp), dimension(NVE), intent(out)         :: gradx

! ... Local variables:
! ...
integer iu,i,step,nsteps
real(dp) to,tf,dt,t
real(dp), dimension(NVE)                      :: x,xn,xr,dd
real(dp), dimension(NVE)                      :: gradJ
real(dp), dimension(NVE)                      :: p

! ... Model time interval:
! ...
dt = lorenz_dt
to = cost_to
tf = cost_tf
nsteps = nint((tf-to)/dt)

if (verbose) then
  write(*,*)
  write(*,*) 'Initial time  = ', to
  write(*,*) 'Final   time  = ', tf
  write(*,*) 'Time interval = ', dt
  write(*,*) 'Model steps   = ', nsteps
endif

! ... Find the obsevation pointer value (observation for the
! ... interval end):
! ...
do step=1,obs%Nobs
  if ((obs%time(step).ge.tf).or. &
      (abs(obs%time(step)-tf).lt.0.01*dt)) then
    obs%p = step
    exit
  endif
enddo
if (obs%time(obs%p).gt.tf+0.01*dt) obs%p = obs%p - 1

! ... Run the forward model, saving each time step solution
! ... The Adjoint code is based on the linearization
! ... around each solution state
! ...
iu = unitfree()
open(iu,file='adj.tmp',status='unknown',form='unformatted', &
        access='direct',recl=dp*(NVE+1))

t = to
x = xo
!print*, 'saving step ', 0, t
write(iu,rec=1) t, x

do step=1,nsteps
  call rk4 (lorenz_n,x,t,dt,xn,lorenz_rhs)
  x = xn
  t = t + dt
  !print*, 'saving step ', step, t
  write(iu,rec=step+1) t, x
enddo
close(iu)

! ... Run the model backwards:
! ...
gradJ(:) = zero
p(:)     = zero

open(iu,file='adj.tmp',status='old',form='unformatted', &
        access='direct',recl=dp*(NVE+1))

read(iu,rec=nsteps+1) t, xr(:)
do step=nsteps,1,-1
  if (obs%p.gt.0) then
    if (abs(obs%time(obs%p)-t).lt.0.01*dt) then
      !print*, 'Assimilating observation ', obs%p, obs%time(obs%p)
      do i=1,NVE
        gradJ(i) = - obs%iobs(i)*(obs%y(i,obs%p)-xr(i))/r2(i)
      enddo
      obs%p = obs%p - 1
    endif
  endif
  read(iu,rec=step) t, lorenz_ref(:)
  call rk4_adj(lorenz_n,p,t,dt,gradJ,lorenz_adj)
enddo

! ... Initial time step
obs%p = 1
read(iu,rec=1) t, xr(:)
if (abs(obs%time(obs%p)-to).lt.0.01*dt) then
  if (verbose) print*, 'Assimilating observation initial time', to
  do i=1,NVE
    gradJ(i) = - obs%iobs(i)*(obs%y(i,obs%p)-xr(i))/r2(i)
    p(i) = p(i) + gradJ(i)
  enddo
endif

! ... Adding the Background term
! ...
if (alpha.ge.1D-8) then
  dd   = xb(:) - xr(:)
  p(:) = p(:) - alpha*MATMUL(Binv,dd)
endif

close(iu,status='DELETE')

gradx(:) = p(:)

end subroutine dCost


      subroutine vecfcn(n,x,fvec,nprob)
      integer n,nprob
      double precision x(n),fvec(n)
c     **********
c
c     subroutine vecfcn
c
c     this subroutine defines fourteen test functions. the first
c     five test functions are of dimensions 2,4,2,4,3, respectively,
c     while the remaining test functions are of variable dimension
c     n for any n greater than or equal to 1 (problem 6 is an
c     exception to this, since it does not allow n = 1).
c
c     the subroutine statement is
c
c       subroutine vecfcn(n,x,fvec,nprob)
c
c     where
c
c       n is a positive integer input variable.
c
c       x is an input array of length n.
c
c       fvec is an output array of length n which contains the nprob
c         function vector evaluated at x.
c
c       nprob is a positive integer input variable which defines the
c         number of the problem. nprob must not exceed 14.
c
c     subprograms called
c
c       fortran-supplied ... datan,dcos,dexp,dsign,dsin,dsqrt,
c                            max0,min0
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iev,ivar,j,k,k1,k2,kp1,ml,mu
      double precision c1,c2,c3,c4,c5,c6,c7,c8,c9,eight,five,h,one,
     *                 prod,sum,sum1,sum2,temp,temp1,temp2,ten,three,
     *                 ti,tj,tk,tpi,two,zero
      double precision dfloat
      data zero,one,two,three,five,eight,ten
     *     /0.0d0,1.0d0,2.0d0,3.0d0,5.0d0,8.0d0,1.0d1/
      data c1,c2,c3,c4,c5,c6,c7,c8,c9
     *     /1.0d4,1.0001d0,2.0d2,2.02d1,1.98d1,1.8d2,2.5d-1,5.0d-1,
     *      2.9d1/
      dfloat(ivar) = ivar
c
c     problem selector.
c
      go to (10,20,30,40,50,60,120,170,200,220,270,300,330,350), nprob
c
c     rosenbrock function.
c
   10 continue
      fvec(1) = one - x(1)
      fvec(2) = ten*(x(2) - x(1)**2)
      go to 380
c
c     powell singular function.
c
   20 continue
      fvec(1) = x(1) + ten*x(2)
      fvec(2) = dsqrt(five)*(x(3) - x(4))
      fvec(3) = (x(2) - two*x(3))**2
      fvec(4) = dsqrt(ten)*(x(1) - x(4))**2
      go to 380
c
c     powell badly scaled function.
c
   30 continue
      fvec(1) = c1*x(1)*x(2) - one
      fvec(2) = dexp(-x(1)) + dexp(-x(2)) - c2
      go to 380
c
c     wood function.
c
   40 continue
      temp1 = x(2) - x(1)**2
      temp2 = x(4) - x(3)**2
      fvec(1) = -c3*x(1)*temp1 - (one - x(1))
      fvec(2) = c3*temp1 + c4*(x(2) - one) + c5*(x(4) - one)
      fvec(3) = -c6*x(3)*temp2 - (one - x(3))
      fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one)
      go to 380
c
c     helical valley function.
c
   50 continue
      tpi = eight*datan(one)
      temp1 = dsign(c7,x(2))
      if (x(1) .gt. zero) temp1 = datan(x(2)/x(1))/tpi
      if (x(1) .lt. zero) temp1 = datan(x(2)/x(1))/tpi + c8
      temp2 = dsqrt(x(1)**2+x(2)**2)
      fvec(1) = ten*(x(3) - ten*temp1)
      fvec(2) = ten*(temp2 - one)
      fvec(3) = x(3)
      go to 380
c
c     watson function.
c
   60 continue
      do 70 k = 1, n
         fvec(k) = zero
   70    continue
      do 110 i = 1, 29
         ti = dfloat(i)/c9
         sum1 = zero
         temp = one
         do 80 j = 2, n
            sum1 = sum1 + dfloat(j-1)*temp*x(j)
            temp = ti*temp
   80       continue
         sum2 = zero
         temp = one
         do 90 j = 1, n
            sum2 = sum2 + temp*x(j)
            temp = ti*temp
   90       continue
         temp1 = sum1 - sum2**2 - one
         temp2 = two*ti*sum2
         temp = one/ti
         do 100 k = 1, n
            fvec(k) = fvec(k) + temp*(dfloat(k-1) - temp2)*temp1
            temp = ti*temp
  100       continue
  110    continue
      temp = x(2) - x(1)**2 - one
      fvec(1) = fvec(1) + x(1)*(one - two*temp)
      fvec(2) = fvec(2) + temp
      go to 380
c
c     chebyquad function.
c
  120 continue
      do 130 k = 1, n
         fvec(k) = zero
  130    continue
      do 150 j = 1, n
         temp1 = one
         temp2 = two*x(j) - one
         temp = two*temp2
         do 140 i = 1, n
            fvec(i) = fvec(i) + temp2
            ti = temp*temp2 - temp1
            temp1 = temp2
            temp2 = ti
  140       continue
  150    continue
      tk = one/dfloat(n)
      iev = -1
      do 160 k = 1, n
         fvec(k) = tk*fvec(k)
         if (iev .gt. 0) fvec(k) = fvec(k) + one/(dfloat(k)**2 - one)
         iev = -iev
  160    continue
      go to 380
c
c     brown almost-linear function.
c
  170 continue
      sum = -dfloat(n+1)
      prod = one
      do 180 j = 1, n
         sum = sum + x(j)
         prod = x(j)*prod
  180    continue
      do 190 k = 1, n
         fvec(k) = x(k) + sum
  190    continue
      fvec(n) = prod - one
      go to 380
c
c     discrete boundary value function.
c
  200 continue
      h = one/dfloat(n+1)
      do 210 k = 1, n
         temp = (x(k) + dfloat(k)*h + one)**3
         temp1 = zero
         if (k .ne. 1) temp1 = x(k-1)
         temp2 = zero
         if (k .ne. n) temp2 = x(k+1)
         fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two
  210    continue
      go to 380
c
c     discrete integral equation function.
c
  220 continue
      h = one/dfloat(n+1)
      do 260 k = 1, n
         tk = dfloat(k)*h
         sum1 = zero
         do 230 j = 1, k
            tj = dfloat(j)*h
            temp = (x(j) + tj + one)**3
            sum1 = sum1 + tj*temp
  230       continue
         sum2 = zero
         kp1 = k + 1
         if (n .lt. kp1) go to 250
         do 240 j = kp1, n
            tj = dfloat(j)*h
            temp = (x(j) + tj + one)**3
            sum2 = sum2 + (one - tj)*temp
  240       continue
  250    continue
         fvec(k) = x(k) + h*((one - tk)*sum1 + tk*sum2)/two
  260    continue
      go to 380
c
c     trigonometric function.
c
  270 continue
      sum = zero
      do 280 j = 1, n
         fvec(j) = dcos(x(j))
         sum = sum + fvec(j)
  280    continue
      do 290 k = 1, n
         fvec(k) = dfloat(n+k) - dsin(x(k)) - sum - dfloat(k)*fvec(k)
  290    continue
      go to 380
c
c     variably dimensioned function.
c
  300 continue
      sum = zero
      do 310 j = 1, n
         sum = sum + dfloat(j)*(x(j) - one)
  310    continue
      temp = sum*(one + two*sum**2)
      do 320 k = 1, n
         fvec(k) = x(k) - one + dfloat(k)*temp
  320    continue
      go to 380
c
c     broyden tridiagonal function.
c
  330 continue
      do 340 k = 1, n
         temp = (three - two*x(k))*x(k)
         temp1 = zero
         if (k .ne. 1) temp1 = x(k-1)
         temp2 = zero
         if (k .ne. n) temp2 = x(k+1)
         fvec(k) = temp - temp1 - two*temp2 + one
  340    continue
      go to 380
c
c     broyden banded function.
c
  350 continue
      ml = 5
      mu = 1
      do 370 k = 1, n
         k1 = max0(1,k-ml)
         k2 = min0(k+mu,n)
         temp = zero
         do 360 j = k1, k2
            if (j .ne. k) temp = temp + x(j)*(one + x(j))
  360       continue
         fvec(k) = x(k)*(two + five*x(k)**2) + one - temp
  370    continue
  380 continue
      return
c
c     last card of subroutine vecfcn.
c
      end


      SUBROUTINE dsprstx(sa,ija,x,b,n)
      INTEGER n,ija(*)
      DOUBLE PRECISION b(n),sa(*),x(n)
      INTEGER i,j,k
      if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprstx'
      do 11 i=1,n
        b(i)=sa(i)*x(i)
11    continue
      do 13 i=1,n
        do 12 k=ija(i),ija(i+1)-1
          j=ija(k)
          b(j)=b(j)+sa(k)*x(i)
12      continue
13    continue
      return
      END

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


! The contents of this test program are adapted from one of the examples
! of the SpFFT library. This was done with permission from the SpFFT
! developer Simon Frasch. Thank you for that! - G.M.

! Note the following copyright and license aspects of the SpFFT library:

! Copyright (c) 2019 ETH Zurich, Simon Frasch
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its contributors
!    may be used to endorse or promote products derived from this software
!    without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.

program test
    use iso_c_binding
    use spfft
    implicit none
    integer :: i, j, k, counter
    integer, parameter :: dimX = 2
    integer, parameter :: dimY = 2
    integer, parameter :: dimZ = 2
    integer, parameter :: maxNumLocalZColumns = dimX * dimY
    integer, parameter :: processingUnit = 1
    integer, parameter :: maxNumThreads = -1
    type(c_ptr) :: grid = c_null_ptr
    type(c_ptr) :: transform = c_null_ptr
    integer :: errorCode = 0
    integer, dimension(dimX * dimY * dimZ * 3):: indices = 0
    complex(C_DOUBLE_COMPLEX), dimension(dimX * dimY * dimZ):: frequencyElements
    complex(C_DOUBLE_COMPLEX), pointer :: spaceDomain(:,:,:)
    type(c_ptr) :: realValuesPtr

    counter = 0
    do k = 1, dimZ
        do j = 1, dimY
            do i = 1, dimX
             frequencyElements(counter + 1) = cmplx(counter, -counter)
             indices(counter * 3 + 1) = i - 1
             indices(counter * 3 + 2) = j - 1
             indices(counter * 3 + 3) = k - 1
             counter = counter + 1
            end do
        end do
    end do

    ! print input
    print *, "Input:"
    do i = 1, size(frequencyElements)
         print *, frequencyElements(i)
    end do

    ! create grid and transform
    errorCode = spfft_grid_create(grid, dimX, dimY, dimZ, maxNumLocalZColumns, processingUnit, maxNumThreads);
    if (errorCode /= SPFFT_SUCCESS) error stop
    errorCode = spfft_transform_create(transform, grid, processingUnit, 0, &
       dimX, dimY, dimZ, dimZ, size(frequencyElements), 0, indices)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! grid can be safely destroyed after creating all required transforms
    errorCode = spfft_grid_destroy(grid)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! set space domain array to use memory allocted by the library
    errorCode = spfft_transform_get_space_domain(transform, processingUnit, realValuesPtr)
    if (errorCode /= SPFFT_SUCCESS) error stop

    ! transform backward
    errorCode = spfft_transform_backward(transform, frequencyElements, processingUnit)
    if (errorCode /= SPFFT_SUCCESS) error stop

    call c_f_pointer(realValuesPtr, spaceDomain, [dimX,dimY,dimZ])

    print *, ""
    print *, "After backward transform:"
    do k = 1, size(spaceDomain, 3)
        do j = 1, size(spaceDomain, 2)
            do i = 1, size(spaceDomain, 1)
             print *, spaceDomain(i, j, k)
            end do
        end do
    end do

    ! transform forward (will invalidate space domain data)
    errorCode = spfft_transform_forward(transform, processingUnit, frequencyElements, 0)
    if (errorCode /= SPFFT_SUCCESS) error stop

    print *, ""
    print *, "After forward transform (without scaling):"
    do i = 1, size(frequencyElements)
             print *, frequencyElements(i)
    end do

    ! destroying the final transform will free the associated memory
    errorCode = spfft_transform_destroy(transform)
    if (errorCode /= SPFFT_SUCCESS) error stop

end program test


c.
c. To find spoint and fpoint of the entrained parcel
c. To decide location to put this parcel into the linear
c. eddy domain.
c.
	subroutine domain(psigma,ngrid,Xn,spoint,fpoint,iseed6,
     &             n_blob, n_blob_final)

        integer n_max
        parameter (n_max = 30)
c integer Xn, spoint,fpoint
        integer Xn, spoint(n_max), fpoint(n_max)
	real*8 psigma
	integer*4 iseed6
        integer n_blob, n_blob_final
        integer n_s(n_max), n_f(n_max), k, i

c.
c. psigma: portion of the entrainment parcel
c. Xn    : grid points of (1-parcel)
c. spoint: start point of this parcel
c. fpoint: final point of this parcel
c.
c. calculate how many grid points (1-parcel) has
c.
        Xn=int( (1.- psigma * n_blob ) * ngrid)
        write(*,*)psigma,ngrid,Xn
c       Xn=int((1.-psigma)*float(ngrid))
c       write(*,*)psigma,ngrid,Xn

c.
c. randomly choosing the spoint and fpoint
c. shown by grid point relative to this parcel.
c.
C	open(27,file='domain.dat1')
C	read(27,*)rand_no

	rand_no = RAND1(iseed6)

c spoint=int(rand_no*Xn)+1
c fpoint=spoint+(ngrid-Xn)-1
c write(*,*)spoint,ngrid,Xn

        n_s (1) = int(rand_no * Xn) + 1
        n_f (1) = n_s(1) + psigma * ngrid - 1
        write(*,*)'n_s(1), n_f(1) = ', n_s(1), n_f(1)
        do i = 2, n_blob
           n_s (i) = n_f(i-1) + int( Xn / n_blob)
           n_f (i) = n_s(i) + psigma * ngrid - 1
           write(*,*)'grid point of entrained blob',i, n_s(i),
     &                n_f(i), Xn
        enddo

* check if n_s or n_f great than ngrid, if it is it needs to re-establish period
* condition
        k = 0
        do i = 1, n_blob
           k = k + 1
           if( (n_s(i) .le. ngrid) .and. (n_f(i) .gt. ngrid) ) then
                spoint (k) = n_s(i)
                fpoint (k) = ngrid
                spoint (k+1) = 1
                fpoint (k+1) = n_f(i) - ngrid
                k = k + 1 ! increase k by 1
           else if ((n_s(i) .gt. ngrid) .and.
     &              (n_f(i) .gt. ngrid) ) then
                spoint (k) = n_s(i) - ngrid
                fpoint (k) = n_f(i) - ngrid
           else
                spoint (k) = n_s(i)
                fpoint (k) = n_f(i)
           endif
           print *, 'k sp, fp =', k, spoint(k), fpoint(k)
        enddo
        n_blob_final = k
        print *, 'n_blob_final = ', n_blob_final

        return
        end


module physical_constants

  ! Preamble:
  ! =========
  ! Physical constants used throuout the OO-GRASP program.
  ! Everything is public here.

  use program_constants

  implicit none

  public

  ! Physics constants and units
  real(dp), parameter :: AMU_Value          = 1.6605402e-27_dp     ! kg
  real(dp), parameter :: Atmosphere_Pres    = 9.80665e+04_dp       ! Pa
  real(dp), parameter :: Avogadro           = 6.0221367e+23_dp     ! 1/mol
  real(dp), parameter :: Bohr_Magneton      = 9.2740154e-24_dp     ! J/T
  real(dp), parameter :: Bohr_Radius        = 5.29177249e-11_dp    ! m
  real(dp), parameter :: Boltzmann          = 1.380657e-23_dp      ! J/K
  real(dp), parameter :: c_Light            = 2.997924580e+08_dp   ! m/s
  real(dp), parameter :: Electron_Compton   = 2.42631058e-12_dp    ! m
  real(dp), parameter :: Electron_Angular   = 5.2729e-35_dp        ! J*s
  real(dp), parameter :: Electron_Charge    =-1.60217738e-19_dp    ! Coul
  real(dp), parameter :: Electron_Mass_Rest = 9.1093897e-31_dp     ! kg
  real(dp), parameter :: Electron_Moment    = 9.2847700e-24_dp     ! J/T
  real(dp), parameter :: Electron_Radius    = 2.81794092e-15_dp    ! m
  real(dp), parameter :: Faraday            = 9.6485309e+04_dp     ! C/mo
  real(dp), parameter :: G_Universal        = 6.67260e-11_dp       ! m^3/(s^2*kg)
  real(dp), parameter :: Light_Year         = 9.46073e+15_dp       ! m
  real(dp), parameter :: Mech_equiv_Heat    = 4.185e+03_dp         ! J/kcal
  real(dp), parameter :: Molar_Volume       = 0.02241410_dp        ! m^3/mol
  real(dp), parameter :: Neutron_Mass       = 1.6749286e-27_dp     ! kg
  real(dp), parameter :: Permeability       = 1.25663706143e-06_dp ! H/m
  real(dp), parameter :: Permittivity       = 8.85418781762e-12_dp ! F/m
  real(dp), parameter :: Planck_Const       = 6.6260754e-34_dp     ! J*s
  real(dp), parameter :: Proton_Mass        = 1.6726230e-27_dp     ! kg
  real(dp), parameter :: Proton_Moment      = 1.41060761e-26_dp    ! J/T
  real(dp), parameter :: Quantum_charge_r   = 4.13556e+12_dp       ! J*s/C
  real(dp), parameter :: Rydberg_inf        = 1.0973731534e+07_dp  ! 1/m
  real(dp), parameter :: Rydberg_Hydrogen   = 1.09678e+07_dp       ! 1/m
  real(dp), parameter :: Std_Atmosphere     = 1.01325e+05_dp       ! Pa
  real(dp), parameter :: Stefan_Boltzmann   = 5.67050e-08_dp       ! W/(m^2*K^4)
  real(dp), parameter :: Thomson_cross_sect = 6.65165e-29_dp       ! m^2
  real(dp), parameter :: Universal_Gas_C    = 8.314510_dp          ! J/mol*K

  ! Astronomy Constants and units
  real(dp), parameter :: AU_Earth_Sun       = 1.4959787e+11_dp     ! m
  real(dp), parameter :: Anomal_Month       = 27.5546_dp           ! days
  real(dp), parameter :: Anomal_Year        = 365.2596_dp          ! days
  real(dp), parameter :: Dracon_Month       = 27.2122_dp           ! days
  real(dp), parameter :: Earth_G            = 9.80665_dp           ! m/s^2
  real(dp), parameter :: Earth_Mass         = 5.974e+24_dp         ! kg
  real(dp), parameter :: Earth_Radius_Eq    = 6.37814e+6_dp        ! m
  real(dp), parameter :: Earth_Radius_Mean  = 6.3781e+6_dp         ! m
  real(dp), parameter :: Earth_Radius_Polar = 6.356755e+6_dp       ! m
  real(dp), parameter :: Julian_Year        = 365.25_dp            ! days
  real(dp), parameter :: Rotation_Day       = 23.93447222_dp       ! hours
  real(dp), parameter :: Siderial_Day       = 23.93446944_dp       ! hours
  real(dp), parameter :: Siderial_Month     = 27.3217_dp           ! days
  real(dp), parameter :: Siderial_Ratio     = 1.0027379092558_dp
  real(dp), parameter :: Siderial_Year      = 365.2564_dp          ! days
  real(dp), parameter :: Solar_Day          = 24.06571111_dp       ! hours
  real(dp), parameter :: Synodic_Month      = 29.5306_dp           ! days
  real(dp), parameter :: Tropical_Year      = 365.2422_dp          ! days

end module physical_constants