! =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================
! Riemann solver in the transverse direction for the acoustics equations
! on general quadrilateral grids.

! Split asdq (= A^* \Delta q, where * = + or -)
! into down-going flux difference bmasdqb (= B^- A^* \Delta q)
! and up-going flux difference bpasdq (= B^+ A^* \Delta q)

    implicit none

    integer, intent(in) :: maxm, meqn, mwaves, mbc, mx, imp, maux
    double precision, intent(in)      :: ql(meqn, 1-mbc:maxm+mbc)
    double precision, intent(in)      :: qr(meqn, 1-mbc:maxm+mbc)
    double precision, intent(out)   :: asdq(meqn, 1-mbc:maxm+mbc)
    double precision, intent(out) :: bmasdq(meqn, 1-mbc:maxm+mbc)
    double precision, intent(out) :: bpasdq(meqn, 1-mbc:maxm+mbc)
    double precision, intent(in)    :: aux1(maux,    1-mbc:maxm+mbc)
    double precision, intent(in)    :: aux2(maux,    1-mbc:maxm+mbc)
    double precision, intent(in)    :: aux3(maux,    1-mbc:maxm+mbc)

    integer :: ixy, ixtran, iytran, ilenrat, i1, i, m
    double precision :: cm, cp, zm, zz, zp, xtran, ytran, asdqt, a1, a2
    double precision :: asdqp, bpasdqp, bpasdqt, bmasdqp, bmasdqt

    if (ixy.eq.1) then
        ixtran = 4
        iytran = 5
        ilenrat = 6
    else
        ixtran = 1
        iytran = 2
        ilenrat = 3
    endif

    do i=2-mbc,mx+mbc
        if (imp.eq.1) then
            i1 = i-1
        else
            i1 = i
        endif

!       pressure component of asdq:
        asdqp = asdq(1,i)
!
!       sound speed in each row of cells:
        cm = aux1(9,i1)
        cp = aux3(9,i1)
!
!       impedances:
        zm = aux1(8,i1)
        zz = aux2(8,i1)
        zp = aux3(8,i1)

!       up-going:
        xtran = aux3(ixtran,i)
        ytran = aux3(iytran,i)

        asdqt = xtran*asdq(2,i) + ytran*asdq(3,i)
        a2 = (asdqp + zz*asdqt) / (zz+zp)
        bpasdqp = a2*zp
        bpasdqt = a2

        bpasdq(1,i) = cp * bpasdqp
        bpasdq(2,i) = cp * xtran*bpasdqt
        bpasdq(3,i) = cp * ytran*bpasdqt

!       down-going:

        xtran = aux2(ixtran,i)
        ytran = aux2(iytran,i)

        asdqt = xtran*asdq(2,i) + ytran*asdq(3,i)
        a1 = (-asdqp + zz*asdqt) / (zm + zz)
        bmasdqp = -a1*zm
        bmasdqt = a1

        bmasdq(1,i) = -cm * bmasdqp
        bmasdq(2,i) = -cm * xtran*bmasdqt
        bmasdq(3,i) = -cm * ytran*bmasdqt

!       scale by ratio of lengths:
        do m=1,3
            bmasdq(m,i) = bmasdq(m,i)*aux2(ilenrat,i)
            bpasdq(m,i) = bpasdq(m,i)*aux3(ilenrat,i)
        enddo
    enddo
    return
    end subroutine rpt2


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_synthesis_routines) scalar_synthesis_gaussian_grid_saved

contains

    ! Purpose:
    !
    !     subroutine shsgs(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshsgs, ierror)
    !
    !     subroutine shsgs performs the spherical harmonic synthesis
    !     on the arrays a and b and stores the result in the array g.
    !     the synthesis is performed on an equally spaced longitude grid
    !     and a gaussian colatitude grid.  the associated legendre functions
    !     are stored rather than recomputed as they are in subroutine
    !     shsgc.  the synthesis is described below at output parameter
    !     g.
    !
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine
    !            compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     isym   = 0  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 array g(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !                 (see description of g below)
    !
    !            = 1  g is antisymmetric about the equator. the synthesis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !            = 2  g is symmetric about the equator. the synthesis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of syntheses.  in the program that calls shsgs,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple synthesis will be performed.  the third
    !            index is the synthesis index which assumes the values
    !            k=1, ..., nt.  for a single synthesis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shagc. if isym equals zero then idg
    !            must be at least nlat.  if isym is nonzero then idg must
    !            be at least nlat/2 if nlat is even or at least (nlat + 1)/2
    !            if nlat is odd.
    !
    !     jdg    the second dimension of the array g as it appears in the
    !            program that calls shagc. jdg must be at least nlon.
    !
    !     a, b    two or three dimensional arrays (see the input parameter
    !            nt) that contain the coefficients in the spherical harmonic
    !            expansion of g(i, j) given below at the definition of the
    !            output parameter g.  a(m, n) and b(m, n) are defined for
    !            indices m=1, ..., mmax and n=m, ..., nlat where mmax is the
    !            maximum (plus one) longitudinal wave number given by
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shsgs. mdab must be at least
    !            min((nlon+2)/2, nlat) if nlon is even or at least
    !            min((nlon + 1)/2, nlat) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays a and b as it appears
    !            in the program that calls shsgs. ndab must be at least nlat
    !
    !     wshsgs an array which must be initialized by subroutine shsgsi.
    !            once initialized, wshsgs can be used repeatedly by shsgs
    !            as long as nlat and nlon remain unchanged.  wshsgs must
    !            not be altered between calls of shsgs.
    !
    !     lshsgs the dimension of the array wshsgs as it appears in the
    !            program that calls shsgs. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgs must be at least
    !
    !            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
    !
    !
    !     output parameters
    !
    !     g      a two or three dimensional array (see input parameter nt)
    !            that contains the discrete function which is synthesized.
    !            g(i, j) contains the value of the function at the gaussian
    !            colatitude point theta(i) and longitude point
    !            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
    !            above at the input parameter isym.  for isym=0, g(i, j)
    !            is given by the the equations listed below.  symmetric
    !            versions are used when isym is greater than zero.
    !
    !     the normalized associated legendre functions are given by
    !
    !     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)
    !
    !     define the maximum (plus one) longitudinal wave number
    !     as   mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !          mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     then g(i, j) = the sum from n=0 to n=nlat-1 of
    !
    !                   .5*pbar(0, n, theta(i))*a(1, n+1)
    !
    !              plus the sum from m=1 to m=mmax-1 of
    !
    !                   the sum from n=m to n=nlat-1 of
    !
    !              pbar(m, n, theta(i))*(a(m+1, n+1)*cos(m*phi(j))
    !                                    -b(m+1, n+1)*sin(m*phi(j)))
    !
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idg
    !            = 6  error in the specification of jdg
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsgs
    !
    module subroutine shsgs(nlat, nlon, mode, nt, g, idg, jdg, a, b, mdab, ndab, wshsgs, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: mode
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: g(idg, jdg, nt)
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsgs(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)             :: mtrunc, lat, late
        integer(ip)             :: required_wavetable_size
        type(SpherepackUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsgs(nlat, nlon)

        call util%check_scalar_transform_inputs(mode, idg, jdg, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsgs, ierror)

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

        ! Set limit on m subscript
        mtrunc = min((nlon+2)/2, nlat)

        ! Set gaussian point nearest equator pointer
        late = (nlat+mod(nlat, 2))/2

        ! Set number of grid points for analysis/synthesis
        select case (mode)
            case (0)
                lat = nlat
            case default
                lat = late
        end select

        block
            real(wp)    :: g_work(lat, nlon, nt)
            integer(ip) :: ifft, ipmn

            ! Starting address for fft values and legendre polys in wshsgs
            ifft = nlat+2*nlat*late+3*(mtrunc*(mtrunc-1)/2+(nlat-mtrunc)*(mtrunc-1))+1
            ipmn = ifft+nlon+15

            call reconstruct_fft_coefficients(nlat, nlon, mtrunc, lat, &
                mode, g, idg, jdg, nt, a, b, mdab, ndab, wshsgs(ifft:), &
                wshsgs(ipmn:), late, g_work)
        end block

    end subroutine shsgs

    ! Purpose
    !
    ! This subroutine must be called before calling shags or shsgs with
    ! fixed nlat, nlon. it precomputes the gaussian weights, points
    ! and all necessary legendre polys and stores them in wshsgs.
    ! these quantities must be preserved when calling shsgs
    ! repeatedly with fixed nlat, nlon.
    !
    !
    !     subroutine shsgsi(nlat, nlon, wshsgs, ierror)
    !
    !     subroutine shsgsi initializes the array wshsgs which can then
    !     be used repeatedly by subroutines shsgs. it precomputes
    !     and stores in wshsgs quantities such as gaussian weights,
    !     legendre polynomial coefficients, and fft trigonometric tables.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     wshsgs an array which must be initialized by subroutine shsgsi.
    !            once initialized, wshsgs can be used repeatedly by shsgs
    !            as long as nlat and nlon remain unchanged.  wshsgs must
    !            not be altered between calls of shsgs.
    !
    !     lshsgs the dimension of the array wshsgs as it appears in the
    !            program that calls shsgs. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgs must be at least
    !
    !            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
    !
    !
    !     output parameter
    !
    !     wshsgs an array which must be initialized before calling shsgs or
    !            once initialized, wshsgs can be used repeatedly by shsgs or
    !            as long as nlat and nlon remain unchanged.  wshsgs must not
    !            altered between calls of shsgs.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshsgs
    !            = 6  failure in compute_gaussian_latitudes_and_weights to compute gaussian points
    !                 (due to failure in eigenvalue routine)
    !
    module subroutine shsgsi(nlat, nlon, wshsgs, ierror)

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

        ! Local variables
        integer(ip) :: ntrunc, l1, l2, lp, late, ipmnf
        integer(ip) :: lwork, ldwork

        associate (lshsgs => size(wshsgs))

            ! Set triangular truncation limit for spherical harmonic basis
            ntrunc = min((nlon+2)/2, nlat)

            ! Set equator or nearest point (if excluded) pointer
            late = (nlat + 1)/2
            l1 = ntrunc
            l2 = late
            lp = nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15

            !  Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 4) then
                ierror = 2
            else if (lshsgs < lp) then
                ierror = 3
            else
                ierror = 0
            end if

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

            ! Set required workspace sizes
            lwork = 4 * nlat * (nlat + 2) + 2
            ldwork = nlat * (nlat + 4)

            block
                real(wp) :: work(lwork), dwork(ldwork)

                !  set preliminary quantites needed to compute and store legendre polys
                call shsgsp(nlat, nlon, wshsgs, lshsgs, dwork, ldwork, ierror)

                ! Check error flag for lower call routine
                if (ierror /= 0) return

                ! Set legendre poly index pointer in wshsgs
                ipmnf = nlat+2*nlat*late+3*(ntrunc*(ntrunc-1)/2+(nlat-ntrunc)*(ntrunc-1))+nlon+16

                call compute_and_store_legendre_polys(nlat, ntrunc, late, wshsgs, work, wshsgs(ipmnf:))
            end block
        end associate

    end subroutine shsgsi

    !
    ! Purpose:
    !
    ! Reconstruct fourier coefficients in g on gaussian grid
    ! using coefficients in a, b
    !
    subroutine reconstruct_fft_coefficients(nlat, nlon, l, lat, mode, gs, idg, jdg, nt, a, b, mdab, &
        ndab, wfft, pmn, late, g)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: nlon
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: lat
        integer(ip), intent(in)     :: mode
        real(wp),    intent(out)    :: gs(idg, jdg, nt)
        integer(ip), intent(in)     :: idg
        integer(ip), intent(in)     :: jdg
        integer(ip), intent(in)     :: nt
        real(wp),    intent(in)     :: a(mdab, ndab, nt)
        real(wp),    intent(in)     :: b(mdab, ndab, nt)
        integer(ip), intent(in)     :: mdab
        integer(ip), intent(in)     :: ndab
        real(wp),    intent(in)     :: wfft(:)
        real(wp),    intent(in)     :: pmn(late, *)
        integer(ip), intent(in)     :: late
        real(wp),    intent(out)    :: g(lat, nlon, nt)

        ! Local variables
        integer(ip)    :: i, k, m, mn, is, ms, ns, lm1, nl2
        integer(ip)    :: lp1, mp1, np1, mp2, meo, mml1
        real(wp)       :: t1, t2, t3, t4
        type(SpherepackUtility) :: util

        ! Initialize to zero
        g = ZERO

        if (nlon == 2*l-2) then
            lm1 = l-1
        else
            lm1 = l
        end if

        select case (mode)
            case (0)

                !  set first column in g
                m = 0
                mml1 = m*(2*nlat-m-1)/2
                do k=1, nt
                    !
                    !   n even
                    !
                    do np1=1, nlat, 2
                        mn = mml1+np1
                        do i=1, late
                            g(i, 1, k) = g(i, 1, k)+a(1, np1, k)*pmn(i, mn)
                        end do
                    end do
                    !
                    !  n odd
                    !
                    nl2 = nlat/2
                    do np1=2, nlat, 2
                        mn = mml1+np1
                        do i=1, nl2
                            is = nlat-i+1
                            g(is, 1, k) = g(is, 1, k)+a(1, np1, k)*pmn(i, mn)
                        end do
                    end do
                end do

                !
                !  restore m=0 coefficients from odd/even
                !
                do k=1, nt
                    do i=1, nl2
                        is = nlat-i+1
                        t1 = g(i, 1, k)
                        t3 = g(is, 1, k)
                        g(i, 1, k) = t1+t3
                        g(is, 1, k) = t1-t3
                    end do
                end do

                !
                !  sweep interior columns of g
                !
                do mp1=2, lm1
                    m = mp1-1
                    mml1 = m*(2*nlat-m-1)/2
                    mp2 = m+2
                    do k=1, nt
                        !
                        !  for n-m even store (g(i, p, k)+g(nlat-i+1, p, k))/2 in g(i, p, k) p=2*m, 2*m+1
                        !    for i=1, ..., late
                        !
                        do np1=mp1, nlat, 2
                            mn = mml1+np1
                            do i=1, late
                                g(i, 2*m, k) = g(i, 2*m, k)+a(mp1, np1, k)*pmn(i, mn)
                                g(i, 2*m+1, k) = g(i, 2*m+1, k)+b(mp1, np1, k)*pmn(i, mn)
                            end do
                        end do
                        !
                        !  for n-m odd store g(i, p, k)-g(nlat-i+1, p, k) in g(nlat-i+1, p, k)
                        !    for i=1, ..., nlat/2 (p=2*m, p=2*m+1)
                        !
                        do np1=mp2, nlat, 2
                            mn = mml1+np1
                            do i=1, nl2
                                is = nlat-i+1
                                g(is, 2*m, k) = g(is, 2*m, k)+a(mp1, np1, k)*pmn(i, mn)
                                g(is, 2*m+1, k) = g(is, 2*m+1, k)+b(mp1, np1, k)*pmn(i, mn)
                            end do
                        end do

                        !
                        !  now set fourier coefficients using even-odd reduction above
                        !
                        do i=1, nl2
                            is = nlat-i+1
                            t1 = g(i, 2*m, k)
                            t2 = g(i, 2*m+1, k)
                            t3 = g(is, 2*m, k)
                            t4 = g(is, 2*m+1, k)
                            g(i, 2*m, k) = t1+t3
                            g(i, 2*m+1, k) = t2+t4
                            g(is, 2*m, k) = t1-t3
                            g(is, 2*m+1, k) = t2-t4
                        end do
                    end do
                end do

                !
                !  set last column (using a only) if necessary
                !
                if (nlon== l+l-2) then
                    m = l-1
                    mml1 = m*(2*nlat-m-1)/2
                    do k=1, nt
                        !
                        !  (n - m) even
                        !
                        do np1=l, nlat, 2
                            mn = mml1+np1
                            do i=1, late
                                g(i, nlon, k) = g(i, nlon, k)+TWO *a(l, np1, k)*pmn(i, mn)
                            end do
                        end do

                        lp1 = l+1
                        !
                        !  (n - m) odd
                        !
                        do np1=lp1, nlat, 2
                            mn = mml1+np1
                            do i=1, nl2
                                is = nlat-i+1
                                g(is, nlon, k) = g(is, nlon, k)+TWO *a(l, np1, k)*pmn(i, mn)
                            end do
                        end do

                        do i=1, nl2
                            is = nlat-i+1
                            t1 = g(i, nlon, k)
                            t3 = g(is, nlon, k)
                            g(i, nlon, k)= t1+t3
                            g(is, nlon, k)= t1-t3
                        end do
                    end do
                end if
            case default
                !     half sphere
                !     set first column in g
                m = 0
                mml1 = m*(2*nlat-m-1)/2

                select case (mode)
                    case (1)
                        meo = 2
                    case default
                        meo = 1
                end select

                ms = m+meo
                do k=1, nt
                    do np1=ms, nlat, 2
                        mn = mml1+np1
                        do i=1, late
                            g(i, 1, k) = g(i, 1, k)+a(1, np1, k)*pmn(i, mn)
                        end do
                    end do
                end do

                !     sweep interior columns of g

                do mp1=2, lm1
                    m = mp1-1
                    mml1 = m*(2*nlat-m-1)/2
                    ms = m+meo
                    do k=1, nt
                        do np1=ms, nlat, 2
                            mn = mml1+np1
                            do i=1, late
                                g(i, 2*m, k) = g(i, 2*m, k)+a(mp1, np1, k)*pmn(i, mn)
                                g(i, 2*m+1, k) = g(i, 2*m+1, k)+b(mp1, np1, k)*pmn(i, mn)
                            end do
                        end do
                    end do
                end do

                if (nlon == 2*l-2) then
                    !
                    !  set last column
                    !
                    m = l-1
                    mml1 = m*(2*nlat-m-1)/2

                    select case (mode)
                        case (1)
                            ns = l+1
                        case default
                            ns = l
                    end select

                    do k=1, nt
                        do np1=ns, nlat, 2
                            mn = mml1+np1
                            do i=1, late
                                g(i, nlon, k) = g(i, nlon, k)+TWO *a(l, np1, k)*pmn(i, mn)
                            end do
                        end do
                    end do
                end if
        end select

        !  Perform inverse fourier transform
        do k=1, nt
            call util%hfft%backward(lat, nlon, g(:, :, k), lat, wfft)
        end do

        !  scale output in gs
        gs(1:lat, 1:nlon, :) = HALF *g(1:lat, 1:nlon, :)

    end subroutine reconstruct_fft_coefficients

    !
    ! Purpose:
    !
    ! Compute and store legendre polys for i=1, ..., late, m=0, ..., l-1
    ! and n=m, ..., l-1
    !
    subroutine compute_and_store_legendre_polys(nlat, l, late, w, pmn, pmnf)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: late
        real(wp),    intent(inout)  :: w(*)
        real(wp),    intent(out)    :: pmn(nlat, late, 3)
        real(wp),    intent(inout)  :: pmnf(late, *)

        ! Local variables
        integer(ip)         :: m, km, mn, mp1, np1, mml1, mode
        type(SpherepackUtility) :: util

        !  Initialize
        pmn = ZERO

        do mp1=1, l
            m = mp1-1
            mml1 = m*(2*nlat-m-1)/2
            !
            !  compute pmn for n=m, ..., nlat-1 and i=1, ..., (l+1)/2
            !
            mode = 0
            call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
            !
            !  store above in pmnf
            !
            do np1=mp1, nlat
                mn = mml1+np1
                pmnf(:, mn) = pmn(np1, :, km)
            end do
        end do

    end subroutine compute_and_store_legendre_polys

    subroutine shsgsp(nlat, nlon, wshsgs, lshsgs, dwork, ldwork, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: nlon
        real(wp),    intent(inout)  :: wshsgs(lshsgs)
        integer(ip), intent(in)     :: lshsgs
        real(wp),    intent(inout)  :: dwork(ldwork)
        integer(ip), intent(in)     :: ldwork
        integer(ip), intent(out)    :: ierror

        ! Local variables
        integer(ip) :: ntrunc, i1, i2, i3, l1, l2, i4, i5, i6, i7
        integer(ip) :: iw, late, idth, idwts

        ! Set triangular truncation limit for spherical harmonic basis
        ntrunc = min((nlon+2)/2, nlat)

        ! Set equator or nearest point (if excluded) pointer
        late = (nlat+mod(nlat, 2))/2
        l1 = ntrunc
        l2 = late

        !
        !  Check calling arguments
        !
        if (nlat < 3) then
            ierror = 1
            return
        else if (nlon < 4) then
            ierror = 2
            return
        else if (lshsgs < nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15) then
            ierror = 3
            return
        else if (ldwork < nlat*(nlat+4)) then
            ierror = 4
            return
        else
            ierror = 0
        end if

        !
        !  set pointers
        !
        i1 = 1
        i2 = i1+nlat
        i3 = i2+nlat*late
        i4 = i3+nlat*late
        i5 = i4+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
        i6 = i5+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
        i7 = i6+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)

        !
        !  set indices in temp work for real gaussian wts and pts
        idth = 1
        idwts = idth+nlat
        iw = idwts+nlat

        call shsgsp_lower_utility_routine(nlat, nlon, ntrunc, late, wshsgs(i1), wshsgs(i2), wshsgs(i3), &
            wshsgs(i4), wshsgs(i5), wshsgs(i6), wshsgs(i7), dwork(idth), &
            dwork(idwts), dwork(iw), ierror)

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

    end subroutine shsgsp

    subroutine shsgsp_lower_utility_routine(nlat, nlon, l, late, wts, p0n, p1n, abel, bbel, cbel, &
        wfft, dtheta, dwts, work, ier)

        ! Dummy arguments
        integer(ip), intent(in)     :: nlat
        integer(ip), intent(in)     :: nlon
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: late
        real(wp),    intent(inout)  :: wts(nlat)
        real(wp),    intent(out)    :: p0n(nlat, late)
        real(wp),    intent(out)    :: p1n(nlat, late)
        real(wp),    intent(out)    :: abel(*)
        real(wp),    intent(out)    :: bbel(*)
        real(wp),    intent(out)    :: cbel(*)
        real(wp),    intent(inout)  :: wfft(*)
        real(wp),    intent(out)    :: dtheta(nlat)
        real(wp),    intent(out)    :: dwts(nlat)
        real(wp),    intent(inout)  :: work(*)
        integer(ip), intent(out)    :: ier

        ! Local variables
        integer(ip)         :: i, m, n, lw, np1, imn, mlim
        real(wp)            :: pb
        type(SpherepackUtility) :: util

        !  Initialize half Fourier transform
        call util%hfft%initialize(nlon, wfft)

        !  compute real gaussian points and weights
        lw = nlat*(nlat+2)
        call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)

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

        !
        !  store gaussian weights single precision to save computation
        !    in inner loops in analysis
        !
        wts = dwts

        !
        !  initialize p0n, p1n using real dnlfk, dnlft
        !
        p0n = ZERO
        p1n = ZERO

        !
        !  compute m=n=0 legendre polynomials for all theta(i)
        !
        np1 = 1
        n = 0
        m = 0
        call util%compute_fourier_coefficients(m, n, work)

        do i=1, late
            call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
            p0n(1, i) = pb
        end do

        !
        !  compute p0n, p1n for all theta(i) when n>0
        !
        do np1=2, nlat
            n = np1-1
            m = 0
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p0n(np1, i) = pb
            end do
            !
            !  compute m=1 legendre polynomials for all n and theta(i)
            !
            m = 1
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p1n(np1, i) = pb
            end do
        end do

        !
        !  compute and store swarztrauber recursion coefficients
        !    for 2<=m<=n and 2<=n<=nlat in abel, bbel, cbel
        !
        do n=2, nlat
            mlim = min(n, l)
            do m=2, mlim
                if (n >= l) then
                    imn = l*(l-1)/2+(n-l-1)*(l-1)+m-1
                else
                    imn = (n-1)*(n-2)/2+m-1
                end if
                abel(imn) = sqrt(real((2*n+1)*(m+n-2)*(m+n-3), kind=wp)/ &
                    real(((2*n-3)*(m+n-1)*(m+n)), kind=wp))
                bbel(imn) = sqrt(real((2*n+1)*(n-m-1)*(n-m), kind=wp)/ &
                    real((2*n-3)*(m+n-1)*(m+n), kind=wp))
                cbel(imn) = sqrt(real((n-m+1)*(n-m+2), kind=wp)/ &
                    real((n+m-1)*(n+m), kind=wp))
            end do
        end do

    end subroutine shsgsp_lower_utility_routine

end submodule scalar_synthesis_gaussian_grid_saved


      SUBROUTINE GOUDRIAANSLAW(lyr,lai,beamrad,diffrad,
     &     fsunlit,qsunlit, fshade,qshade)
      IMPLICIT NONE

      REAL*8 lyr,lai,beamrad,diffrad
      REAL*8 fsunlit,qsunlit,fshade,qshade

      REAL*8 soilalbedo,leafalbedo,canopyalbedo
      REAL*8 albedobeam,albedodiff
      REAL*8 m
      REAL*8 kbeam,kdiff,kbeamstar

c     value from Wang
      soilalbedo=0.15d0
c     leaf transmittance and reflectance are equal. Then albedo is the double
      leafalbedo=2.0d0*0.075d0

c     extinction coefficent of the direct beam
      kbeam=0.5d0
c     extinction coefficient of diffuse radiations
      kdiff=0.66d0
c     I found somewhere an approximate relation: kbeam=0.75*kdiff

      m=sqrt(1.0d0-leafalbedo)
      kbeamstar=m*kbeam

      canopyalbedo=2.0d0*kbeam/(kbeam+kdiff)*(1.0d0-m)/(1.0d0+m)
      albedobeam=canopyalbedo+(soilalbedo-canopyalbedo)
     &     *exp(-kbeam*lai)
c     ... hum, I don't know if albedodiff is really different or not... so equal
      albedodiff=albedobeam

      qshade=(1.0d0-albedodiff)*diffrad*kdiff*exp(-kdiff*lyr)
     & +(1.0d0-albedobeam)*beamrad*kbeam*exp(-kbeam*lyr)
     & -(1.0d0-leafalbedo)*beamrad*kbeamstar*exp(-kbeamstar*lyr)
      IF (qshade.LT.0.0d0) qshade=0.0d0

      qsunlit=(1.0d0-leafalbedo)*kbeamstar*beamrad+qshade

      fsunlit=exp(-kbeam*lyr)
      fshade=1-fsunlit

      END

      SUBROUTINE BEERSLAW(lyr,beamrad,diffrad,
     &     fsunlit,qsunlit, fshade,qshade)
      IMPLICIT NONE
      REAL*8 lyr,beamrad,diffrad
      REAL*8 fsunlit,qsunlit,fshade,qshade
      REAL*8 kbeam,kdiff

c     extinction coefficent of the direct beam
      kbeam=0.5d0
c     extinction coefficient of diffuse radiations
      kdiff=0.66d0

      fshade=1.0d0
      fsunlit=0

      qsunlit=0.0d0
      qshade=beamrad*kbeam*exp(-kbeam*lyr)+diffrad*kdiff*exp(-kdiff*lyr)

      END

      SUBROUTINE SUNFLECT(lyr,beamrad,diffrad,
     &     fsunlit,qsunlit, fshade,qshade)
      IMPLICIT NONE
      REAL*8 lyr,beamrad,diffrad
      REAL*8 fsunlit,qsunlit,fshade,qshade
      REAL*8 kbeam,kdiff

c     extinction coefficent of the direct beam
      kbeam=0.5d0
c     extinction coefficient of diffuse radiations
      kdiff=0.66d0

      fsunlit=0.5d0
      fshade=0.5d0

      qsunlit=beamrad*kbeam*exp(-kbeam*lyr)+
     &     diffrad*kdiff*exp(-kdiff*lyr)
      qshade=qsunlit

      END


! 2017, S.A. Sato, Modified the format of the code
! ----------------------------------------------------------------------------
! Numerical diagonalization of 3x3 matrcies
! Copyright (C) 2006  Joachim Kopp
! ----------------------------------------------------------------------------
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.
!
! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ----------------------------------------------------------------------------

! ----------------------------------------------------------------------------
      SUBROUTINE ZHEEVH3(A, Q, W)
! ----------------------------------------------------------------------------
! Calculates the eigenvalues and normalized eigenvectors of a hermitian 3x3
! matrix A using Cardano's method for the eigenvalues and an analytical
! method based on vector cross products for the eigenvectors. However,
! if conditions are such that a large error in the results is to be
! expected, the routine falls back to using the slower, but more
! accurate QL algorithm. Only the diagonal and upper triangular parts of A need
! to contain meaningful values. Access to A is read-only.
! ----------------------------------------------------------------------------
! Parameters:
!   A: The hermitian input matrix
!   Q: Storage buffer for eigenvectors
!   W: Storage buffer for eigenvalues
! ----------------------------------------------------------------------------
! Dependencies:
!   SQRABS(), ZHEEVC3(), ZHETRD3(), ZHEEVQ3()
! ----------------------------------------------------------------------------
! Version history:
!   v1.2 (12 Mar 2012): Removed unused label to avoid gfortran warning
!   v1.1: Simplified fallback condition --> speed-up
!   v1.0: First released version
! ----------------------------------------------------------------------------
!     .. Arguments ..
      COMPLEX(8)       A(3,3)
      COMPLEX(8)       Q(3,3)
      DOUBLE PRECISION W(3)

!     .. Parameters ..
      DOUBLE PRECISION EPS
      PARAMETER        ( EPS = 2.2204460492503131D-16 )

!     .. Local Variables ..
      DOUBLE PRECISION NORM
      DOUBLE PRECISION ERROR
      DOUBLE PRECISION T, U
      INTEGER          J

!     .. External Functions ..
      DOUBLE PRECISION SQRABS
      EXTERNAL         SQRABS, ZHEEVC3, ZHEEVQ3

!     Calculate eigenvalues
      CALL ZHEEVC3(A, W)

!     --- The rest of this subroutine can be omitted if only the eigenvalues are desired ---

!     Prepare calculation of eigenvectors
!      N1      = DREAL(A(1, 1))**2 + SQRABS(A(1, 2)) + SQRABS(A(1, 3))
!      N2      = SQRABS(A(1, 2)) + DREAL(A(2, 2))**2 + SQRABS(A(2, 3))
      T       = MAX(ABS(W(1)), ABS(W(2)), ABS(W(3)))
      U       = MAX(T, T**2)
      ERROR   = 256.0D0 * EPS * U**2
!      ERROR   = 256.0D0 * EPS * (N1 + U) * (N2 + U)
      Q(1, 2) = A(1, 2) * A(2, 3) - A(1, 3) * DREAL(A(2, 2))
      Q(2, 2) = A(1, 3) * DCONJG(A(1, 2)) - A(2, 3) * DREAL(A(1, 1))
      Q(3, 2) = SQRABS(A(1, 2))

!     Calculate first eigenvector by the formula
!       v[0] = conj( (A - lambda[0]).e1 x (A - lambda[0]).e2 )
      Q(1, 1) = Q(1, 2) + A(1, 3) * W(1)
      Q(2, 1) = Q(2, 2) + A(2, 3) * W(1)
      Q(3, 1) = (DREAL(A(1,1)) - W(1)) * (DREAL(A(2,2)) - W(1)) - Q(3,2)
      NORM    = SQRABS(Q(1, 1)) + SQRABS(Q(2, 1)) + SQRABS(Q(3, 1))

!     If vectors are nearly linearly dependent, or if there might have
!     been large cancellations in the calculation of A(I,I) - W(1), fall
!     back to QL algorithm
!     Note that this simultaneously ensures that multiple eigenvalues do
!     not cause problems: If W(1) = W(2), then A - W(1) * I has rank 1,
!     i.e. all columns of A - W(1) * I are linearly dependent.
      IF (NORM .LE. ERROR) THEN
        CALL ZHEEVQ3(A, Q, W)
        RETURN
!     This is the standard branch
      ELSE
        NORM = SQRT(1.0D0 / NORM)
        DO 20, J = 1, 3
          Q(J, 1) = Q(J, 1) * NORM
   20   CONTINUE
      END IF

!     Calculate second eigenvector by the formula
!       v[1] = conj( (A - lambda[1]).e1 x (A - lambda[1]).e2 )
      Q(1, 2) = Q(1, 2) + A(1, 3) * W(2)
      Q(2, 2) = Q(2, 2) + A(2, 3) * W(2)
      Q(3, 2) = (DREAL(A(1,1)) - W(2)) * (DREAL(A(2,2)) - W(2)) &
        - DREAL(Q(3, 2))
      NORM    = SQRABS(Q(1, 2)) + SQRABS(Q(2, 2)) + DREAL(Q(3, 2))**2
      IF (NORM .LE. ERROR) THEN
        CALL ZHEEVQ3(A, Q, W)
        RETURN
      ELSE
        NORM = SQRT(1.0D0 / NORM)
        DO 40, J = 1, 3
          Q(J, 2) = Q(J, 2) * NORM
   40   CONTINUE
      END IF

!     Calculate third eigenvector according to
!       v[2] = conj(v[0] x v[1])
      Q(1, 3) = DCONJG( Q(2, 1) * Q(3, 2) - Q(3, 1) * Q(2, 2) )
      Q(2, 3) = DCONJG( Q(3, 1) * Q(1, 2) - Q(1, 1) * Q(3, 2) )
      Q(3, 3) = DCONJG( Q(1, 1) * Q(2, 2) - Q(2, 1) * Q(1, 2) )

      END SUBROUTINE
! End of subroutine ZHEEVH3


! ======================================================================
! PROGRAM MOMENTUM
! ----------------------------------------------------------------------
      PROGRAM MOMENTUM
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: CURRENT_FILE
      INTEGER :: OUTPUT_SHIFT
      INTEGER :: START_MOMENTUM
      INTEGER :: END_MOMENTUM

      REAL :: RADIUS
      REAL :: NONLINEAR_COUPLING
      REAL :: GAMMA_FACTOR
      REAL :: ROTATION_RATE

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_MOMENTUM
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE
      REAL :: CHEMICAL_POTENTIAL
      REAL :: TIME

      COMPLEX :: FOURIER_COEFFICIENT

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) CURRENT_FILE

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) OUTPUT_SHIFT

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NONLINEAR_COUPLING

      CALL GET_COMMAND_ARGUMENT(8,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

      CALL GET_COMMAND_ARGUMENT(9,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ROTATION_RATE

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = (RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR)

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))

!     Main Program:
!     -------------
      OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='UNFORMATTED',STATUS='OLD')
      READ(UNIT=CURRENT_FILE) WAVEFUNCTION
      CLOSE(UNIT=CURRENT_FILE,STATUS='SAVE')
      OPEN(UNIT=CURRENT_FILE+OUTPUT_SHIFT,ACTION='WRITE',FORM='FORMATTED',STATUS='NEW')
      DO CURRENT_MOMENTUM = START_MOMENTUM, END_MOMENTUM
         FOURIER_COEFFICIENT = CMPLX(0.0E0,0.0E0)
         CHEMICAL_POTENTIAL = FLOAT(CURRENT_MOMENTUM**2)/(2.0E0*RADIUS**2)-FLOAT(CURRENT_MOMENTUM)*ROTATION_RATE+NONLINEAR_COUPLING/(2.0E0*PI*RADIUS)
         TIME = FLOAT(CURRENT_FILE-1000)*TIME_STEP_SIZE
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            FOURIER_COEFFICIENT = FOURIER_COEFFICIENT+WAVEFUNCTION(CURRENT_GRID_POINT)*EXP(CMPLX(0.0E0,-FLOAT(CURRENT_MOMENTUM)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE+CHEMICAL_POTENTIAL*TIME))
         ENDDO
         FOURIER_COEFFICIENT=FOURIER_COEFFICIENT*CMPLX(RADIUS*ANGULAR_GRID_SPACING_SIZE/SQRT(2.0E0*PI*RADIUS),0.0E0)
         WRITE(CURRENT_FILE+OUTPUT_SHIFT,900) CURRENT_MOMENTUM, ABS(FOURIER_COEFFICIENT)**2, REAL(FOURIER_COEFFICIENT), AIMAG(FOURIER_COEFFICIENT)
      ENDDO
      CLOSE(UNIT=CURRENT_FILE+OUTPUT_SHIFT,STATUS='SAVE')

!     Format Statements:
!     ------------------
900   FORMAT(1X,1(I5),3(F23.15))

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)

      STOP
      ENDPROGRAM MOMENTUM
! ======================================================================


function func(x,y)
real*8::x,func,y
func=-y
end

program ecuaciones
implicit none
external func
REAL*8,ALLOCATABLE,DIMENSION(:)::y,t
integer*4::n,i,M
real*8::func,xo,yo,a,b,K1,K2,DT
M=5
a=0.
b=2.6
xo=0
yo=1
DT=0.2
allocate(t(M+1),y(M))
do i=0,M
t(i)=xo+DT*i
PRINT*, t(i)
end do
y(1)=yo
do n=1,M
K1=func(y(n),t(n))
K2=func(y(n)+(K1)*DT,t(n+1))
y(n+1)=((K2+K1)/2.)*DT
end do
print*, y(:)
end


function temps(bwtdmx,bwtdmn,bctopt,bctmin)
!
implicit none
!
! Dummy arguments
!
real :: bctmin,bctopt,bwtdmn,bwtdmx
real :: temps
!
! Local variables
!
real :: dst0,rto,tgx,x1
!
!     + + + purpose + + +
!     to calculate the temperature stress factor
!     this algorithms was taken from the epic subroutine cgrow.

!     + + + kewords + + +
!     temperature stress

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bwtdmx - daily maximum air temperature
!     bwtdmn - daily minimum air temperature
!     bctopt - optimum crop growth temperature
!     bctmin - minimum crop growth temperature
!     temps - value returned by this function for the temperature
!             stress factor

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     dst0 - average of max and min air temperatures
!     rto - interim variable
!     tgx - difference between the soil surface temperature and the minimum
!           temperature for plant growth
!     x1 - difference between the optimum and minimum temperatures for plant
!          growth

!     + + + end of specifications + + +

!     calculate temperature stress factor
!     following one statement to be removed when soil temperature is available
dst0 = (bwtdmx+bwtdmn)/2.0
tgx = dst0 - bctmin
if (tgx<=0.) tgx = 0.
x1 = bctopt - bctmin
rto = tgx/x1
temps = sin(1.5707*rto)
if (rto>2.) temps = 0.

      ! this reduces temperature stress around the optimum
temps = temps**0.25
!    print *, 'in temps, temps = ', temps
!
end function temps


PROGRAM ComputeEigensystem_NuclearEOS

  USE KindModule, ONLY: &
    DP
  USE UnitsModule, ONLY: &
    Gram, Centimeter, Kelvin, &
    AtomicMassUnit, Dyne, Erg, &
    Second, MeV, Meter
  USE PhysicalConstantsModule, ONLY: &
    SpeedOfLightMKS
  USE UtilitiesModule, ONLY: &
    WriteMatrix
  USE EquationOfStateModule_TABLE, ONLY: &
    InitializeEquationOfState_TABLE, &
    ApplyEquationOfState_TABLE
  USE EulerEquationsUtilitiesModule_TABLE, ONLY: &
    ComputeEigenvectors_L, &
    ComputeEigenvectors_R

  IMPLICIT NONE

  REAL(DP) :: BaryonMass = AtomicMassUnit

  REAL(DP), DIMENSION(1)   :: D, T, Y, P, S, E, Me, Mp, Mn
  REAL(DP), DIMENSION(1)   :: Xp, Xn, Xa, Xh, Gm, Tau, N
  REAL(DP), DIMENSION(6,6) :: dFdU, L, R, Matrix, DD, RL, LR
  REAL(DP), DIMENSION(3)   :: V
  REAL(DP), DIMENSION(6)   :: lambda

  INTEGER :: i, k

  D   = [ 1.20d10 * Gram / Centimeter**3 ]
  T   = [ 3.1_DP * MeV ]
  Y   = [ 0.26_DP ]
  v   = [ 0.1_DP, 0.1_DP, 0.1_DP ]
  Tau = 1.0_DP / D

  CALL InitializeEquationOfState_TABLE &
         ( 'EquationOfStateTable.h5' )

  CALL ApplyEquationOfState_TABLE &
         ( D, T, Y, P, S, E, Me, Mp, Mn, Xp, Xn, Xa, Xh, Gm )

  CALL ComputeEigenvectors_L &
         ( D, T, Y, v(1), v(2), v(3), lambda, L, dFdU, .FALSE. )

  DD = 0.0d0
  DO i = 1, 6
    DD(i,i) = lambda(i)
  END DO

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'dFdU:'
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A8,6ES20.10E3)') '', DFDU(i,:)
  END DO

  Matrix = MATMUL( TRANSPOSE(L), dFdU ) - MATMUL( DD, TRANSPOSE(L) )

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'L^T dFdU - D L^T:'
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A8,6ES20.10E3)') '', Matrix(i,:)
  END DO

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'Eigenvalues (L):'
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A11,I2.2,A1,ES20.10E3)') '', i, '', lambda(i)
  END DO

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'Sound Speed (Table):'
  WRITE(*,*)
  WRITE(*,'(A8,ES20.10E3)') '', SQRT( Gm * P / D )
  WRITE(*,*)

  CALL ComputeEigenvectors_R &
         ( D, T, Y, v(1), v(2), v(3), lambda, R, dFdU, .FALSE. )

  DD = 0.0d0
  DO i = 1, 6
    DD(i,i) = lambda(i)
  END DO

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'Eigenvalues (R):'
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A11,I2.2,A1,ES20.10E3)') '', i, '', DD(i,i)
  END DO

  Matrix = MATMUL( dFdU, R ) - MATMUL( R, DD )

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'dFdU R - R D:'
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A8,6ES20.10E3)') '', Matrix(i,:)
  END DO

  RL = MATMUL( R, L )
  LR = MATMUL( L, R )

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'R L: '
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A8,6ES20.10E3)') '', RL(i,:)
  END DO

  WRITE(*,*)
  WRITE(*,'(A8,A)') '', 'L R: '
  WRITE(*,*)
  DO i = 1, 6
    WRITE(*,'(A8,6ES20.10E3)') '', LR(i,:)
  END DO
  WRITE(*,*)

END PROGRAM ComputeEigensystem_NuclearEOS


      subroutine pc_coeff(xr,nd,nt,u,npc,var,xpc)
      real var(nt)
      complex u(nt,npc),xr(nd,nt),xpc(nd,npc)
      include 'nstamx.inc'
      integer i1(ntmx)
      real usc(ntmx)

ccc   given NT total data channels with estimated noise
ccc   variances of VAR, and NPC principal components U,
ccc   from the "PC coefficients" ...

      do i = 1,nt
         i1(i) = i
      enddo

ccc   scale PCs to allow for noise variations
      do j =  1,nt
         sc = sqrt(var(j))
         do ip = 1,npc
            u(j,ip) = u(j,ip)/sc
         enddo
      enddo
      do ip = 1,npc
         usc(ip) = 0.0
         do j = 1,nt
            usc(ip) = usc(ip) + u(j,ip)**2.
         enddo
      enddo
      do j =  1,nt
         sc = sqrt(var(j))
         do ip = 1,npc
            u(j,ip) = u(j,ip)/(sc*usc(ip))
         enddo
      enddo

      call lc_dat(xr,nd,nt,u,nt,npc,i1,xpc)

ccc   return PCs to original scaling
      do ip = 1,npc
         do j =  1,nt
            u(j,ip) = u(j,ip)*var(j)*usc(ip)
         enddo
      enddo
      return
      end


!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! DESCRIPTION:
!> @brief This module is filter manager.
!>
!> @details Filtering method to be used is specify inside variable strcuture,
!>    as array of string character.

!>    td_var\%c_filter(1) string character is the filter name choose between:

!>       - 'hann'
!>          - rad < cutoff : @f$ filter=0.5+0.5*COS(\pi*\frac{rad}{cutoff}) @f$
!>          - rad > cutoff : @f$ filter=0 @f$
!>       - 'hamming'
!>          - rad < cutoff : @f$ filter=0.54+0.46*COS(\pi*\frac{rad}{cutoff}) @f$
!>          - rad > cutoff : @f$ filter=0 @f$
!>       - 'blackman'
!>          - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) +
!>                                      0.08*COS(2\pi*\frac{rad}{cutoff}) @f$
!>          - rad > cutoff : @f$ filter=0 @f$
!>       - 'gauss'
!>          - @f$filter=exp(-(\alpha * rad^2) / (2*cutoff^2))@f$
!>       - 'butterworth'
!>          - @f$ filer=1 / (1+(rad^2 / cutoff^2)^{\alpha}) @f$
!>             .
!>
!>       with @f$ rad= \sqrt{(dist-radius)^2} @f$
!>
!>    td_var\%c_filter(2) string character is the number of turn to be done

!>    td_var\%c_filter(3) string character is the cut-off frequency
! >                       (count in number of mesh grid)

!>    td_var\%c_filter(4) string character is the halo radius
!>                        (count in number of mesh grid)

!>    td_var\%c_filter(5) string character is the alpha parameter
!>                        (for gauss and butterworth method)

!>
!>    @note Filter method could be specify for each variable in namelist _namvar_,
!>    defining string character _cn\_varinfo_. None by default.

!>    Filter method parameters are informed inside bracket.
!>       - @f$\alpha@f$ parameter is added for _gauss_ and _butterworth_ methods
!>
!>    The number of turn is specify using '*' separator.

!>    Example:
!>       - cn_varinfo='varname1:flt=2*hamming(@f$cutoff@f$,@f$radius@f$)',
!>                    'varname2:flt=gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)'
!>
!>    to filter variable value:

!> @code
!>    CALL filter_fill_value( td_var )
!> @endcode
!>       - td_var is variable structure
!>
!> @author
!> J.Paul
!>
!> @date November, 2013 - Initial Version
!>
!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE filter

   USE kind                            ! F90 kind parameter
   USE phycst                          ! physical constant
   USE logger                          ! log file manager
   USE fct                             ! basic usefull function
   use att                             ! attribute manager
   USE var                             ! variable manager
   USE extrap                          ! extrapolation manager

   IMPLICIT NONE
   ! NOTE_avoid_public_variables_if_possible

   ! type and variable

   ! function and subroutine
   PUBLIC :: filter_fill_value   !< filter variable value

   PRIVATE :: filter__fill_value_wrapper !
   PRIVATE :: filter__fill_value         !
   PRIVATE :: filter__3D_fill_value      !
   PRIVATE :: filter__2D_fill_value      !
   PRIVATE :: filter__2D                 !
   PRIVATE :: filter__2D_coef            !
   PRIVATE :: filter__2D_hann            !
   PRIVATE :: filter__2D_hamming         !
   PRIVATE :: filter__2D_blackman        !
   PRIVATE :: filter__2D_gauss           !
   PRIVATE :: filter__2D_butterworth     !
   PRIVATE :: filter__1D_fill_value      !
   PRIVATE :: filter__1D                 !
   PRIVATE :: filter__1D_coef            !
   PRIVATE :: filter__1D_hann            !
   PRIVATE :: filter__1D_hamming         !
   PRIVATE :: filter__1D_blackman        !
   PRIVATE :: filter__1D_gauss           !
   PRIVATE :: filter__1D_butterworth     !

   INTERFACE filter_fill_value
      MODULE PROCEDURE filter__fill_value_wrapper
   END INTERFACE filter_fill_value

CONTAINS
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__fill_value_wrapper(td_var)
   !-------------------------------------------------------------------
   !> @brief
   !> This subroutine filter variable value.
   !>
   !> @details
   !> it checks if filtering method is available,
   !>  gets parameter value, and launch filter__fill_value
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] td_var variable structure
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TVAR), INTENT(INOUT) :: td_var

      ! local variable
      CHARACTER(LEN=lc) :: cl_filter
      CHARACTER(LEN=lc) :: cl_method
      INTEGER(I4)       :: il_radius
      INTEGER(I4)       :: il_nturn
      REAL(dp)          :: dl_cutoff
      REAL(dp)          :: dl_alpha

      TYPE(TATT)        :: tl_att

      ! loop indices
      INTEGER(I4) :: jl
      !----------------------------------------------------------------

      IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
         CALL logger_error("FILTER FILL VALUE: no array of value "//&
         &  "associted to variable "//TRIM(td_var%c_name) )
      ELSE

         SELECT CASE(TRIM(td_var%c_filter(1)))

         CASE DEFAULT

            CALL logger_trace("FILTER FILL VALUE: no filter selected "//&
            &  "for variable "//TRIM(td_var%c_name))

         CASE('hann','hamming','blackman','gauss','butterworth')

            cl_method=TRIM(td_var%c_filter(1))

            ! look for number of turn to be done
            READ(td_var%c_filter(2),*) il_nturn
            IF( il_nturn < 0 )THEN
               CALL logger_error("FILTER FILL VALUE: invalid "//&
               &  "number of turn ("//TRIM(td_var%c_filter(2))//")")
            ENDIF

            ! look for cut-off frequency
            dl_cutoff=2
            IF( TRIM(td_var%c_filter(3)) /= '' )THEN
               READ(td_var%c_filter(3),*) dl_cutoff
            ENDIF
            IF( dl_cutoff < 0 )THEN
               CALL logger_error("FILTER FILL VALUE: invalid cut-off "//&
               &  "frequency ("//TRIM(td_var%c_filter(3))//")")
            ENDIF

            ! look for halo size
            il_radius=1
            IF( TRIM(td_var%c_filter(4)) /= '' )THEN
               READ(td_var%c_filter(4),*) il_radius
            ENDIF
            IF( il_radius < 0 )THEN
               CALL logger_error("FILTER FILL VALUE: invalid halo radius "//&
               &  " ("//TRIM(td_var%c_filter(4))//")")
            ENDIF

            IF( REAL(2*il_radius+1,dp) < dl_cutoff )THEN
               CALL logger_error("FILTER FILL VALUE: radius of halo and "//&
               &  "spatial cut-off frequency are not suitable.")
            ENDIF

            ! look for alpha parameter
            dl_alpha=2
            IF( TRIM(td_var%c_filter(5)) /= '' )THEN
               READ(td_var%c_filter(5),*) dl_alpha
            ENDIF

            SELECT CASE(TRIM(cl_method))
            CASE('gauss','butterworth')
               CALL logger_info("FILTER FILL VALUE: filtering "//&
               &   " variable "//TRIM(td_var%c_name)//&
               &   " using "//TRIM(fct_str(il_nturn))//" turn"//&
               &   " of "//TRIM(cl_method)//" method,"//&
               &   " with cut-off frequency of "//&
               &        TRIM(fct_str(REAL(dl_cutoff,sp)))//&
               &   ", halo's radius of "//&
               &        TRIM(fct_str(il_radius))//&
               &   ", and alpha parameter of "//&
               &        TRIM(fct_str(REAL(dl_alpha,sp))) )
            CASE DEFAULT
               CALL logger_info("FILTER FILL VALUE: filtering "//&
               &   " variable "//TRIM(td_var%c_name)//&
               &   " using "//TRIM(fct_str(il_nturn))//" turn"//&
               &   " of "//TRIM(cl_method)//" method,"//&
               &   " with cut-off frequency of "//&
               &        TRIM(fct_str(REAL(dl_cutoff,sp)))//&
               &   " and halo's radius of "//&
               &        TRIM(fct_str(il_radius)) )
            END SELECT

            IF( .NOT. ANY(td_var%t_dim(1:3)%l_use) )THEN
               ! no dimension I-J-K used
               CALL logger_debug("FILTER FILL VALUE: no filtering can "//&
               &  "be done for variable "//TRIM(td_var%c_name))
            ELSE

               ! add attribute to variable
               SELECT CASE(TRIM(cl_method))
               CASE('gauss','butterworth')
                  cl_filter=TRIM(fct_str(il_nturn))//'*'//TRIM(cl_method)//&
                  &                    '('//TRIM(fct_str(REAL(dl_cutoff,sp)))//","//&
                  &                         TRIM(fct_str(il_radius))//","//&
                  &                         TRIM(fct_str(REAL(dl_alpha,sp)))//')'
               CASE DEFAULT
                  cl_filter=TRIM(fct_str(il_nturn))//'*'//TRIM(cl_method)//&
                  &                    '('//TRIM(fct_str(REAL(dl_cutoff,sp)))//","//&
                  &                         TRIM(fct_str(il_radius))//')'
               END SELECT
               tl_att=att_init('filter',cl_filter)
               CALL var_move_att(td_var,tl_att)
               ! clean
               CALL att_clean(tl_att)

               DO jl=1,il_nturn
                  CALL filter__fill_value( td_var, TRIM(cl_method),  &
                  &                        dl_cutoff, il_radius, dl_alpha )
               ENDDO
            ENDIF

         END SELECT

      ENDIF
   END SUBROUTINE filter__fill_value_wrapper
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__fill_value(td_var, cd_name, &
         &                       dd_cutoff, id_radius, dd_alpha)
   !-------------------------------------------------------------------
   !> @brief
   !> This subroutine filtering variable value, given cut-off frequency
   !> halo radius and alpha parameter.
   !>
   !> @details
   !>    First extrabands are added to array of variable value.
   !>    Then values are extrapolated, before apply filter.
   !>    Finally extrabands are removed.
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] td_var variable
   !> @param[in] cd_name   filter name
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      TYPE(TVAR)      , INTENT(INOUT) :: td_var
      CHARACTER(LEN=*), INTENT(IN   ) :: cd_name
      REAL(dp)        , INTENT(IN   ) :: dd_cutoff
      INTEGER(I4)     , INTENT(IN   ) :: id_radius
      REAL(dp)        , INTENT(IN   ) :: dd_alpha

      ! local variable
      TYPE(TVAR)                                         :: tl_mask

      INTEGER(i1)      , DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask

      ! loop indices
      INTEGER(i4) :: jl
      !----------------------------------------------------------------

      CALL logger_debug("FILTER: "//TRIM(fct_str(td_var%d_fill)) )

      !1-add extraband
      CALL extrap_add_extrabands(td_var, id_radius, id_radius)

      !2-compute mask
      ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, &
      &                td_var%t_dim(2)%i_len, &
      &                td_var%t_dim(3)%i_len, &
      &                td_var%t_dim(4)%i_len) )

      bl_mask(:,:,:,:)=1
      WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0

      tl_mask=var_init('tmask', bl_mask(:,:,:,:))

      DEALLOCATE(bl_mask)

      !3-extrapolate
      CALL extrap_fill_value( td_var ) !, id_iext=id_radius, id_jext=id_radius )

      !4-filtering
      DO jl=1,td_var%t_dim(4)%i_len
         IF( ALL(td_var%t_dim(1:3)%l_use) )THEN
            ! dimension I-J-K used
            CALL filter__3D_fill_value( td_var%d_value(:,:,:,jl),       &
            &                           td_var%d_fill, TRIM(cd_name), &
            &                           dd_cutoff, id_radius, dd_alpha)
         ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
            ! dimension I-J used
            CALL filter__2D_fill_value( td_var%d_value(:,:,1,jl),       &
            &                           td_var%d_fill, TRIM(cd_name), &
            &                           dd_cutoff, id_radius, dd_alpha)
         ELSE IF( td_var%t_dim(3)%l_use )THEN
            ! dimension K used
            CALL filter__1D_fill_value( td_var%d_value(1,1,:,jl),       &
            &                           td_var%d_fill, TRIM(cd_name), &
            &                           dd_cutoff, id_radius, dd_alpha)
         ENDIF
      ENDDO

      !5-keep original mask
      WHERE( tl_mask%d_value(:,:,:,:) == 0 )
         td_var%d_value(:,:,:,:)=td_var%d_fill
      END WHERE

      ! clean
      CALL var_clean(tl_mask)

      !6-remove extraband
      CALL extrap_del_extrabands(td_var, id_radius, id_radius)

   END SUBROUTINE filter__fill_value
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__3D_fill_value(dd_value, dd_fill, cd_name, &
         &                          dd_cutoff, id_radius, dd_alpha)
   !-------------------------------------------------------------------
   !> @brief This subroutine compute filtered value of 3D array.
   !>
   !> @details
   !>    First compute filter coefficient.
   !>    Then apply it on each level of variable value.
   !>
   !> @warning array of value should have been already extrapolated before
   !> running this subroutine.
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  array of value to be filtered
   !> @param[in] dd_fill      fill value
   !> @param[in] cd_name      filter name
   !> @param[in] dd_cutoff    cut-off frequency
   !> @param[in] id_radius    filter halo radius
   !> @param[in] dd_alpha     filter parameter
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:,:,:), INTENT(INOUT) :: dd_value
      REAL(dp)        ,                   INTENT(IN   ) :: dd_fill
      CHARACTER(LEN=*),                   INTENT(IN   ) :: cd_name
      REAL(dp)        ,                   INTENT(IN   ) :: dd_cutoff
      INTEGER(i4)     ,                   INTENT(IN   ) :: id_radius
      REAL(dp)        ,                   INTENT(IN   ) :: dd_alpha

      ! local variable
      INTEGER(i4), DIMENSION(3)                :: il_shape
      REAL(dp)   , DIMENSION(:,:), ALLOCATABLE :: dl_coef

      ! loop indices
      INTEGER(i4) :: jk
      !----------------------------------------------------------------

      il_shape(:)=SHAPE(dd_value(:,:,:))

      ALLOCATE( dl_coef(2*id_radius+1,2*id_radius+1) )

      dl_coef(:,:)=filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha)

      DO jk=1,il_shape(3)
         CALL filter__2D(dd_value(:,:,jk), dd_fill,dl_coef(:,:),id_radius)
      ENDDO

      DEALLOCATE( dl_coef )

   END SUBROUTINE filter__3D_fill_value
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__2D_fill_value(dd_value, dd_fill, cd_name, &
         &                          dd_cutoff, id_radius, dd_alpha)
   !-------------------------------------------------------------------
   !> @brief This subroutine compute filtered value of 2D array.
   !>
   !> @details
   !>    First compute filter coefficient.
   !>    Then apply it on variable value.
   !>
   !> @warning array of value should have been already extrapolated before
   !> running this subroutine.
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  array of value to be filtered
   !> @param[in] dd_fill      fill value
   !> @param[in] cd_name      filter name
   !> @param[in] dd_cutoff    cut-off frequency
   !> @param[in] id_radius    filter halo radius
   !> @param[in] dd_alpha     filter parameter
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:,:), INTENT(INOUT) :: dd_value
      REAL(dp)        ,                 INTENT(IN   ) :: dd_fill
      CHARACTER(LEN=*),                 INTENT(IN   ) :: cd_name
      REAL(dp)        ,                 INTENT(IN   ) :: dd_cutoff
      INTEGER(i4)     ,                 INTENT(IN   ) :: id_radius
      REAL(dp)        ,                 INTENT(IN   ) :: dd_alpha

      ! local variable

      REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_coef
      ! loop indices
      !----------------------------------------------------------------

      ALLOCATE( dl_coef(2*id_radius+1,2*id_radius+1) )

      dl_coef(:,:)=filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha)

      CALL filter__2D(dd_value(:,:), dd_fill, dl_coef(:,:), id_radius)

      DEALLOCATE( dl_coef )

   END SUBROUTINE filter__2D_fill_value
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__1D_fill_value(dd_value, dd_fill, cd_name, &
         &                          dd_cutoff, id_radius, dd_alpha)
   !-------------------------------------------------------------------
   !> @brief This subroutine compute filtered value of 1D array.
   !>
   !> @details
   !>    First compute filter coefficient.
   !>    Then apply it on variable value.
   !>
   !> @warning array of value should have been already extrapolated before
   !> running this subroutine.
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  array of value to be filtered
   !> @param[in] dd_fill      fill value
   !> @param[in] cd_name      filter name
   !> @param[in] dd_cutoff    cut-off frequency
   !> @param[in] id_radius    filter halo radius
   !> @param[in] dd_alpha     filter parameter
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:), INTENT(INOUT) :: dd_value
      REAL(dp)        ,               INTENT(IN   ) :: dd_fill
      CHARACTER(LEN=*),               INTENT(IN   ) :: cd_name
      REAL(dp)        ,               INTENT(IN   ) :: dd_cutoff
      INTEGER(i4)     ,               INTENT(IN   ) :: id_radius
      REAL(dp)        ,               INTENT(IN   ) :: dd_alpha

      ! local variable

      REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_coef
      ! loop indices
      !----------------------------------------------------------------

      ALLOCATE( dl_coef(2*id_radius+1) )

      dl_coef(:)=filter__1D_coef(cd_name, dd_cutoff, id_radius, dd_alpha)

      CALL filter__1D(dd_value(:), dd_fill, dl_coef(:),id_radius)

      DEALLOCATE( dl_coef )

   END SUBROUTINE filter__1D_fill_value
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__2D(dd_value, dd_fill, dd_coef, id_radius)
   !-------------------------------------------------------------------
   !> @brief This subroutine filtered 2D array of value
   !>
   !> @details
   !>    loop on first and second dimension,
   !>    and apply coefficient 2D array on each point
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  array of value to be filtered
   !> @param[in] dd_fill      fill value
   !> @param[in] dd_coef      filter coefficent array
   !> @param[in] id_radius    filter halo radius
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:,:), INTENT(INOUT) :: dd_value
      REAL(dp)        ,                 INTENT(IN   ) :: dd_fill
      REAL(dp)        , DIMENSION(:,:), INTENT(IN   ) :: dd_coef
      INTEGER(i4)     ,                 INTENT(IN   ) :: id_radius

      ! local variable
      INTEGER(i4), DIMENSION(2)                :: il_shape
      REAL(dp)   , DIMENSION(:,:), ALLOCATABLE :: dl_value
      REAL(dp)   , DIMENSION(:,:), ALLOCATABLE :: dl_halo

      ! loop indices
      INTEGER(i4) :: jj
      INTEGER(i4) :: ji
      !----------------------------------------------------------------
      il_shape(:)=SHAPE(dd_value(:,:))

      ALLOCATE(dl_value(il_shape(1),il_shape(2)))
      dl_value(:,:)=dd_value(:,:)

      ALLOCATE(dl_halo(2*id_radius+1,2*id_radius+1))

      DO jj=1+id_radius,il_shape(2)-id_radius
         DO ji=1+id_radius,il_shape(1)-id_radius

            dl_halo(:,:)=dd_fill
            dl_halo(:,:)=dl_value(ji-id_radius:ji+id_radius, &
            &                     jj-id_radius:jj+id_radius)

            dd_value(ji,jj)=SUM(dl_halo(:,:)*dd_coef(:,:))

         ENDDO
      ENDDO

      DEALLOCATE(dl_halo)
      DEALLOCATE(dl_value)

   END SUBROUTINE filter__2D
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   SUBROUTINE filter__1D(dd_value, dd_fill, dd_coef, id_radius)
   !-------------------------------------------------------------------
   !> @brief This subroutine filtered 1D array of value
   !>
   !> @details
   !>    loop on first dimension,
   !>    and apply coefficient 1D array on each point
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[inout] dd_value  array of value to be filtered
   !> @param[in] dd_fill      fill value
   !> @param[in] dd_coef      filter coefficent array
   !> @param[in] id_radius    filter halo radius
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , DIMENSION(:), INTENT(INOUT) :: dd_value
      REAL(dp)        ,               INTENT(IN   ) :: dd_fill
      REAL(dp)        , DIMENSION(:), INTENT(IN   ) :: dd_coef
      INTEGER(i4)     ,               INTENT(IN   ) :: id_radius

      ! local variable
      INTEGER(i4), DIMENSION(1)              :: il_shape
      REAL(dp)   , DIMENSION(:), ALLOCATABLE :: dl_value

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------
      il_shape(:)=SHAPE(dd_value(:))

      ALLOCATE(dl_value(2*id_radius+1))

      DO ji=1+id_radius,il_shape(1)-id_radius

         dl_value(:)=dd_fill
         dl_value(:)=dd_value(ji-id_radius:ji+id_radius)

         dd_value(ji)=SUM(dl_value(:)*dd_coef(:))

      ENDDO

      DEALLOCATE(dl_value)

   END SUBROUTINE filter__1D
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute filter coefficient.
   !>
   !> @details
   !>
   !> filter could be choose between :
   !> - hann
   !> - hamming
   !> - blackman
   !> - gauss
   !> - butterworth
   !> Cut-off frequency could be specify.
   !> As well as a filter parameter for gauss and butterworth filter
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] cd_name   filter name
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      CHARACTER(LEN=*), INTENT(IN) :: cd_name
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable

      ! loop indices
      !----------------------------------------------------------------
      IF( REAL(id_radius,dp) < dd_cutoff )THEN
         CALL logger_warn("FILTER COEF: radius of the filter halo "//&
         &  "is lower than cut-off frequency")
      ENDIF

      SELECT CASE(TRIM(fct_lower(cd_name)))
      CASE('hann')
         df_coef(:,:)=filter__2D_hann(dd_cutoff, id_radius)
      CASE('hamming')
         df_coef(:,:)=filter__2D_hamming(dd_cutoff, id_radius)
      CASE('blackman')
         df_coef(:,:)=filter__2D_blackman(dd_cutoff, id_radius)
      CASE('gauss')
         df_coef(:,:)=filter__2D_gauss(dd_cutoff, id_radius, dd_alpha)
      CASE('butterworth')
         df_coef(:,:)=filter__2D_butterworth(dd_cutoff, id_radius, dd_alpha)
      CASE DEFAULT
         CALL logger_error("FILTER COEF: invalid filter name :"//TRIM(cd_name))
      END SELECT

   END FUNCTION filter__2D_coef
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_coef(cd_name, dd_cutoff, id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute filter coefficient.
   !>
   !> @details
   !>
   !> filter could be choose between :
   !> - hann
   !> - hamming
   !> - blackman
   !> - gauss
   !> - butterworth
   !> Cut-off frequency could be specify.
   !> As well as a filter parameter for gauss an butterworth filter
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] cd_name   filter name
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      CHARACTER(LEN=*), INTENT(IN) :: cd_name
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable

      ! loop indices
      !----------------------------------------------------------------

      SELECT CASE(TRIM(fct_lower(cd_name)))
      CASE('hann')
         df_coef(:)=filter__1D_hann(dd_cutoff, id_radius)
      CASE('hamming')
         df_coef(:)=filter__1D_hamming(dd_cutoff, id_radius)
      CASE('blackman')
         df_coef(:)=filter__1D_blackman(dd_cutoff, id_radius)
      CASE('gauss')
         df_coef(:)=filter__1D_gauss(dd_cutoff, id_radius, dd_alpha)
      CASE('butterworth')
         df_coef(:)=filter__1D_butterworth(dd_cutoff, id_radius, dd_alpha)
      CASE DEFAULT
         CALL logger_error("FILTER COEF: invalid filter name :"//TRIM(cd_name))
      END SELECT

   END FUNCTION filter__1D_coef
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_hann(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for HANN filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of hann filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:)=0.
         df_coef(id_radius+1)=1.
      ELSE
         DO ji=1,2*id_radius+1

            dl_rad=SQRT(REAL(ji-id_radius+1,dp)**2 )

            IF( dl_rad < dd_cutoff )THEN
               df_coef(ji)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff)
            ELSE
               df_coef(ji)=0
            ENDIF

         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:))

         df_coef(:)=df_coef(:)/dl_sum
      ENDIF

   END FUNCTION filter__1D_hann
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_hann(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for HANN filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of hann filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)   , INTENT(IN) :: dd_cutoff
      INTEGER(i4), INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      IF( dd_cutoff < 1.0_dp )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:,:)=0.
         df_coef(id_radius+1,id_radius+1)=1.
      ELSE
         DO jj=1,2*id_radius+1
            DO ji=1,2*id_radius+1

               ! radius
               dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + &
               &             REAL(jj-(id_radius+1),dp)**2 )

               IF( dl_rad < dd_cutoff )THEN
                  df_coef(ji,jj)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff)
               ELSE
                  df_coef(ji,jj)=0
               ENDIF

            ENDDO
         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:,:))

         df_coef(:,:)=df_coef(:,:)/dl_sum
      ENDIF

   END FUNCTION filter__2D_hann
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_hamming(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for HAMMING filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of hamming filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:)=0.
         df_coef(id_radius+11)=1.
      ELSE
         DO ji=1,2*id_radius+1

            dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 )

            IF( dl_rad < dd_cutoff )THEN
               df_coef(ji)= 0.54 + 0.46*COS(dp_pi*dl_rad/dd_cutoff)
            ELSE
               df_coef(ji)=0
            ENDIF

         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:))

         df_coef(:)=df_coef(:)/dl_sum
      ENDIF

   END FUNCTION filter__1D_hamming
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_hamming(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for HAMMING filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of hamming filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:,:)=0.
         df_coef(id_radius+1,id_radius+1)=1.
      ELSE
         DO jj=1,2*id_radius+1
            DO ji=1,2*id_radius+1

               dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + &
                  &          REAL(jj-(id_radius+1),dp)**2 )

               IF( dl_rad < dd_cutoff )THEN
                  df_coef(ji,jj)= 0.54 + 0.46*COS(dp_pi*dl_rad/dd_cutoff)
               ELSE
                  df_coef(ji,jj)=0
               ENDIF

            ENDDO
         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:,:))

         df_coef(:,:)=df_coef(:,:)/dl_sum
      ENDIF

   END FUNCTION filter__2D_hamming
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_blackman(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for BLACKMAN filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of blackman filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:)=0.
         df_coef(id_radius+1)=1.
      ELSE
         DO ji=1,2*id_radius+1

            dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 )

            IF( dl_rad < dd_cutoff )THEN
               df_coef(ji)= 0.42 + 0.5 *COS(  dp_pi*dl_rad/dd_cutoff) &
                  &              + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff)
            ELSE
               df_coef(ji)=0
            ENDIF

         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:))

         df_coef(:)=df_coef(:)/dl_sum
      ENDIF

   END FUNCTION filter__1D_blackman
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_blackman(dd_cutoff, id_radius) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for BLACKMAN filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @return array of blackman filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:,:)=0.
         df_coef(id_radius+1,id_radius+1)=1.
      ELSE
         DO jj=1,2*id_radius+1
            DO ji=1,2*id_radius+1

               dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + &
               &             REAL(jj-(id_radius+1),dp)**2 )

               IF( dl_rad < dd_cutoff )THEN
                  df_coef(ji,jj)= 0.42 + 0.5 *COS(  dp_pi*dl_rad/dd_cutoff) &
                     &                 + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff)
               ELSE
                  df_coef(ji,jj)=0
               ENDIF

            ENDDO
         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:,:))

         df_coef(:,:)=df_coef(:,:)/dl_sum
      ENDIF

   END FUNCTION filter__2D_blackman
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_gauss(dd_cutoff, id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for GAUSS filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of gauss filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:)=0.
         df_coef(id_radius+1)=1.
      ELSE
         DO ji=1,2*id_radius+1

            dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 )

            df_coef(ji)=EXP(-(dd_alpha*dl_rad**2)/(2*dd_cutoff**2))

         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:))

         df_coef(:)=df_coef(:)/dl_sum
      ENDIF

   END FUNCTION filter__1D_gauss
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_gauss(dd_cutoff, id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for GAUSS filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of gauss filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      IF( dd_cutoff < 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than or equal to 1. No filter will be apply ")
         df_coef(:,:)=0.
         df_coef(id_radius+1,id_radius+1)=1.
      ELSE
         DO jj=1,2*id_radius+1
            DO ji=1,2*id_radius+1

               dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + &
                  &          REAL(jj-(id_radius+1),dp)**2 )

               df_coef(ji,jj)=EXP(-(dd_alpha*dl_rad**2)/(2*dd_cutoff**2))

            ENDDO
         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:,:))

         df_coef(:,:)=df_coef(:,:)/dl_sum
      ENDIF

   END FUNCTION filter__2D_gauss
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__1D_butterworth(dd_cutoff, id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for BUTTERWORTH filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of butterworth filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      !----------------------------------------------------------------

      IF( dd_cutoff <= 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than 1. No filter will be apply ")
         df_coef(:)=0.
         df_coef(id_radius+1)=1.
      ELSE
         DO ji=1,2*id_radius+1

            dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 )

            df_coef(ji)= 1 / (1+(dl_rad**2/dd_cutoff**2)**dd_alpha)

         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:))

         df_coef(:)=df_coef(:)/dl_sum
      ENDIF

   END FUNCTION filter__1D_butterworth
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   FUNCTION filter__2D_butterworth(dd_cutoff,  id_radius, dd_alpha) &
         & RESULT (df_coef)
   !-------------------------------------------------------------------
   !> @brief This function compute coefficient for BUTTERWORTH filter.
   !>
   !> @details
   !>
   !> @author J.Paul
   !> @date November, 2013 - Initial Version
   !>
   !> @param[in] dd_cutoff cut-off frequency
   !> @param[in] id_radius filter halo radius
   !> @param[in] dd_alpha  filter parameter
   !> @return array of butterworth filter coefficient
   !-------------------------------------------------------------------

      IMPLICIT NONE

      ! Argument
      REAL(dp)        , INTENT(IN) :: dd_cutoff
      INTEGER(i4)     , INTENT(IN) :: id_radius
      REAL(dp)        , INTENT(IN) :: dd_alpha

      ! function
      REAL(dp), DIMENSION(2*id_radius+1,2*id_radius+1) :: df_coef

      ! local variable
      REAL(dp) :: dl_rad
      REAL(dp) :: dl_sum

      ! loop indices
      INTEGER(i4) :: ji
      INTEGER(i4) :: jj
      !----------------------------------------------------------------

      IF( dd_cutoff <= 1 )THEN
         CALL logger_error("FILTER COEF: cut-off frequency "//&
         &  "should be greater than 1. No filter will be apply ")
         df_coef(:,:)=0.
         df_coef(id_radius+1,id_radius+1)=1.
      ELSE
         DO jj=1,2*id_radius+1
            DO ji=1,2*id_radius+1

               dl_rad= SQRT( REAL(ji-(id_radius+1),dp)**2 + &
                  &          REAL(jj-(id_radius+1),dp)**2 )

               df_coef(ji,jj)= 1 / (1+(dl_rad**2/dd_cutoff**2)**dd_alpha)

            ENDDO
         ENDDO

         ! normalize
         dl_sum=SUM(df_coef(:,:))

         df_coef(:,:)=df_coef(:,:)/dl_sum
      ENDIF

   END FUNCTION filter__2D_butterworth
   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
END MODULE filter


program main
  implicit none
  double precision x, y
  read(5,*) x, y
  write(6,*) 100.*(x*x-y)**2+(1.-x)**2
end program main