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

! Parameter confined to the submodule
integer(ip), parameter :: SIZE_OF_WORKSPACE_INDICES = 10

contains

    ! Purpose:
    !
    ! Performs the spherical harmonic analysis on
    ! a gaussian grid on the array(s) in g and returns the coefficients
    ! in array(s) a, b. the necessary legendre polynomials are fully
    ! stored in this version.
    !
    !     subroutine shags(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshags, ierror)
    !
    !     subroutine shags performs the spherical harmonic analysis
    !     on the array g and stores the result in the arrays a and b.
    !     the analysis is performed on a gaussian grid in colatitude
    !     and an equally spaced grid in longitude.  the associated
    !     legendre functions are stored rather than recomputed as they
    !     are in subroutine shagc.  the analysis is described below
    !     at output parameters a, b.
    !
    !     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 analysis
    !                 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 analysis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis 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 analysis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of analyses.  in the program that calls shags,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple analyses will be performed.  the third
    !            index is the analysis index which assumes the values
    !            k=1, ..., nt.  for a single analysis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     g      a two or three dimensional array (see input parameter
    !            nt) that contains the discrete function to be analyzed.
    !            g(i, j) contains the value of the function at the gaussian
    !            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
    !            the index ranges are defined above at the input parameter
    !            isym.
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shags. 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 shags. jdg must be at least nlon.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shags. 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 shags. ndab must be at least nlat
    !
    !     wshags an array which must be initialized by subroutine shagsi.
    !            once initialized, wshags can be used repeatedly by shags
    !            as long as nlat and nlon remain unchanged.  wshags must
    !            not be altered between calls of shags.
    !
    !     lshags the dimension of the array wshags as it appears in the
    !            program that calls shags. 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 lshags must be at least
    !
    !            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
    !
    !     output parameters
    !
    !     a, b    both a, b are two or three dimensional arrays (see input
    !            parameter nt) that contain the spherical harmonic
    !            coefficients in the representation of g(i, j) given in the
    !            discription of subroutine shags. for isym=0, a(m, n) and
    !            b(m, n) are given by the equations listed below. symmetric
    !            versions are used when isym is greater than zero.
    !
    !     definitions
    !
    !     1. the normalized associated legendre functions
    !
    !     pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
    !                       *sin(theta)**m/(2**n*factorial(n)) times the
    !                       (n+m)th derivative of (x**2-1)**n with respect
    !                       to x=cos(theta).
    !
    !     2. the fourier transform of g(i, j).
    !
    !     c(m, i)          = 2/nlon times the sum from j=1 to j=nlon of
    !                       g(i, j)*cos((m-1)*(j-1)*2*pi/nlon)
    !                       (the first and last terms in this sum
    !                       are divided by 2)
    !
    !     s(m, i)          = 2/nlon times the sum from j=2 to j=nlon of
    !                       g(i, j)*sin((m-1)*(j-1)*2*pi/nlon)
    !
    !
    !     3. the gaussian points and weights on the sphere
    !        (computed by subroutine compute_gaussian_latitudes_and_weights).
    !
    !        theta(1), ..., theta(nlat) (gaussian pts in radians)
    !        wts(1), ..., wts(nlat) (corresponding gaussian weights)
    !
    !
    !     4. the maximum (plus one) longitudinal wave number
    !
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !
    !     then for m=0, ..., mmax-1 and n=m, ..., nlat-1 the arrays a, b
    !     are given by
    !
    !     a(m+1, n+1)     =  the sum from i=1 to i=nlat of
    !                       c(m+1, i)*wts(i)*pbar(m, n, theta(i))
    !
    !     b(m+1, n+1)      = the sum from i=1 to nlat of
    !                       s(m+1, i)*wts(i)*pbar(m, n, theta(i))
    !
    !     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 lshags
    !
    module subroutine shags(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshags, ierror)

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

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

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

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

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

        ! Set m limit for pmn
        ntrunc = 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 (isym)
            case (0)
                lat = nlat
            case default
                lat = late
        end select

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

            ! Set starting address for gaussian wts , fft values,
            ! and fully stored legendre polys in wshags
            iwts = 1
            ifft = nlat+2*nlat*late+3*(ntrunc*(ntrunc-1)/2+(nlat-ntrunc)*(ntrunc-1))+1
            ipmn = ifft+nlon+15

            call shags_lower_utility_routine(nlat, nlon, ntrunc, lat, isym, g, &
                idg, jdg, nt, a, b, mdab, ndab, wshags(iwts:), wshags(ifft:), &
                wshags(ipmn:), late, g_work)
        end block

    end subroutine shags

    !     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 wshags.
    !     these quantities must be preserved when calling shags or shsgs
    !     repeatedly with fixed nlat, nlon.  dwork must be of length at
    !     least nlat*(nlat+4) in the routine calling shagsi.  This is
    !     not checked.  undetectable errors will result if dwork is
    !     smaller than nlat*(nlat+4).
    !
    !
    !     subroutine shagsi(nlat, nlon, wshags, lshags, work, lwork, dwork, ldwork, ierror)
    !
    !     subroutine shagsi initializes the array wshags which can then
    !     be used repeatedly by subroutines shags. it precomputes
    !     and stores in wshags 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.
    !
    !     wshags an array which must be initialized by subroutine shagsi.
    !            once initialized, wshags can be used repeatedly by shags
    !            as long as nlat and nlon remain unchanged.  wshags must
    !            not be altered between calls of shags.
    !
    !     lshags the dimension of the array wshags as it appears in the
    !            program that calls shags. 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 lshags must be at least
    !
    !            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
    !
    !     work   a real workspace which need not be saved
    !
    !     lwork  the dimension of the array work as it appears in the
    !            program that calls shagsi. lwork must be at least
    !            4*nlat*(nlat+2)+2 in the routine calling shagsi
    !
    !     dwork   a real work array that does not have to be saved.
    !
    !     ldwork  the length of dwork in the calling routine.  ldwork must
    !             be at least nlat*(nlat+4)
    !
    !     output parameter
    !
    !     wshags an array which must be initialized before calling shags or
    !            once initialized, wshags can be used repeatedly by shags or
    !            as long as nlat and nlon remain unchanged.  wshags must not
    !            altered between calls of shasc.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshags
    !            = 4  error in the specification of lwork
    !            = 5  error in the specification of ldwork
    !            = 6  failure in compute_gaussian_latitudes_and_weights to compute gaussian points
    !                 (due to failure in eigenvalue routine)
    !
    module subroutine shagsi(nlat, nlon, wshags, ierror)

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

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

        associate (lshags => size(wshags))

            ! 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

            ! Set permanent workspace length
            lp = nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15

            ! Set preliminary quantites needed to compute and store legendre polys
            ldw = nlat*(nlat+4)

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

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

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

                ! Call lower routine
                call shagsi_lower_utility_routine(nlat, nlon, wshags, lshags, dwork, ldwork, ierror)

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

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

                call shagsi_compute_and_store_legendre_polys(nlat, ntrunc, late, wshags, &
                    work, wshags(ipmnf:))
            end block
        end associate

    end subroutine shagsi

    subroutine shags_lower_utility_routine(nlat, nlon, l, lat, mode, gs, idg, jdg, nt, a, b, mdab, &
        ndab, wts, 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(in)  :: gs(idg, jdg, nt)
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: a(mdab, ndab, nt)
        real(wp),    intent(out) :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        integer(ip), intent(in)  :: late
        real(wp),    intent(in)  :: wfft(:)
        real(wp),    intent(in)  :: pmn(late, *)
        real(wp),    intent(in)  :: wts(nlat)
        real(wp),    intent(out) :: g(lat, nlon, nt)

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

        !  set gs array internally in shags_lower_utility_routine
        g(1:lat, 1:nlon, :) = gs(1:lat, 1:nlon, :)

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

        !  scale result
        sfn = TWO/nlon
        g = sfn * g

        !     compute using gaussian quadrature
        !     a(n, m) = s (ga(theta, m)*pnm(theta)*sin(theta)*dtheta)
        !     b(n, m) = s (gb(theta, m)*pnm(theta)*sin(theta)*dtheta)
        !     here ga, gb are the cos(phi), sin(phi) coefficients of
        !     the fourier expansion of g(theta, phi) in phi.  as a result
        !     of the above fourier transform they are stored in array
        !     g as follows:
        !     for each theta(i) and k= l-1
        !     ga(0), ga(1), gb(1), ga(2), gb(2), ..., ga(k-1), gb(k-1), ga(k)
        !     correspond to
        !     g(i, 1), g(i, 2), g(i, 3), g(i, 4), g(i, 5), ..., g(i, 2l-4), g(i, 2l-3), g(i, 2l-2)
        !     whenever 2*l-2 = nlon exactly
        !     initialize coefficients to zero
        a = ZERO
        b = ZERO

        !  set mp1 limit on b(mp1) calculation
        if (nlon == 2*l-2) then
            lm1 = l-1
        else
            lm1 = l
        end if

        if (mode == 0) then
            !     for full sphere (mode=0) and even/odd reduction:
            !     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
            !     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
            nl2 = nlat/2
            do k=1, nt
                do j=1, nlon
                    do i=1, nl2
                        is = nlat-i+1
                        t1 = g(i, j, k)
                        t2 = g(is, j, k)
                        g(i, j, k) = wts(i)*(t1+t2)
                        g(is, j, k) = wts(i)*(t1-t2)
                    end do
                    !
                    !  adjust equator if necessary(nlat odd)
                    if (odd(nlat)) g(late, j, k) = wts(late) * g(late, j, k)
                end do
            end do

            !  set m = 0 coefficients first
            mp1 = 1
            m = 0
            mml1 = m*(2*nlat-m-1)/2
            do k=1, nt
                do i=1, late
                    is = nlat-i+1
                    do np1=1, nlat, 2

                        !  n even
                        a(1, np1, k) = a(1, np1, k)+g(i, 1, k)*pmn(i, mml1+np1)
                    end do
                    do np1=2, nlat, 2

                        !  n odd
                        a(1, np1, k) = a(1, np1, k)+g(is, 1, k)*pmn(i, mml1+np1)
                    end do
                end do
            end do

            !  compute m >= 1  coefficients next
            do mp1=2, lm1
                m = mp1-1
                mml1 = m*(2*nlat-m-1)/2
                mp2 = mp1+1
                do k=1, nt
                    do i=1, late
                        is = nlat-i+1

                        !  (n - m) even
                        do np1=mp1, nlat, 2
                            a(mp1, np1, k) = a(mp1, np1, k)+g(i, 2*m, k)*pmn(i, mml1+np1)
                            b(mp1, np1, k) = b(mp1, np1, k)+g(i, 2*m+1, k)*pmn(i, mml1+np1)
                        end do

                        !  (n - m) odd
                        do np1=mp2, nlat, 2
                            a(mp1, np1, k) = a(mp1, np1, k)+g(is, 2*m, k)*pmn(i, mml1+np1)
                            b(mp1, np1, k) = b(mp1, np1, k)+g(is, 2*m+1, k)*pmn(i, mml1+np1)
                        end do
                    end do
                end do
            end do

            if (nlon == 2*l-2) then

                !  compute m=l-1, n=l-1, l, ..., nlat-1 coefficients
                m = l-1
                mml1 = m*(2*nlat-m-1)/2
                do k=1, nt
                    do i=1, late
                        is = nlat-i+1
                        do np1=l, nlat, 2
                            mn = mml1+np1
                            a(l, np1, k) = a(l, np1, k) + HALF * g(i, nlon, k) * pmn(i, mn)
                        end do

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

            !  half sphere
            !  overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1, ..., nlate/2

            nl2 = nlat/2
            do  k=1, nt
                do j=1, nlon
                    g(1:nl2, j, k) = wts(1:nl2)*(g(1:nl2, j, k)+g(1:nl2, j, k))
                    !
                    !  adjust equator separately if a grid point
                    !
                    if (nl2 < late) g(late, j, k) = wts(late) * g(late, j, k)

                end do
            end do

            !  set m = 0 coefficients first
            mp1 = 1
            m = 0
            mml1 = m*(2*nlat-m-1)/2

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

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

            !  compute m >= 1  coefficients next
            do mp1=2, lm1
                m = mp1-1
                mml1 = m*(2*nlat-m-1)/2

                select case (mode)
                    case (1)
                        ms = mp1+1
                    case default
                        ms = mp1
                end select

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

            if (nlon == 2*l-2) then
                !  compute n=m=l-1 coefficients last
                m = l-1
                mml1 = m*(2*nlat-m-1)/2

                select case (mode)
                    case (1)
                        !  set starting n for mode odd
                        ns = l+1
                    case default
                        !  set starting n for mode even
                        ns = l
                end select

                do k=1, nt
                    do i=1, late
                        a(l, ns:nlat:2, k) = a(l, ns:nlat:2, k) &
                            + HALF * g(i, nlon, k) * pmn(i, mml1+ns:mml1+nlat:2)
                    end do
                end do
            end if
        end if

    end subroutine shags_lower_utility_routine

    subroutine shagsi_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(inout)  :: pmn(nlat, late, 3)
        real(wp),    intent(inout)  :: pmnf(late, *)

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

        !  Compute and store legendre polys for i=1, ..., late, m=0, ..., l-1
        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
                do i=1, late
                    pmnf(i, mn) = pmn(np1, i, km)
                end do
            end do
        end do

    end subroutine shagsi_compute_and_store_legendre_polys

    subroutine shagsi_lower_utility_routine(nlat, nlon, wshags, lshags, dwork, ldwork, ierror)

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

        ! Local variables
        integer(ip) :: ntrunc, l1, l2, late
        integer(ip) :: workspace_indices(SIZE_OF_WORKSPACE_INDICES)

        ! 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
        else if (nlon < 4) then
            ierror = 2
        else if (lshags < nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15) then
            ierror = 3
        else if (ldwork < nlat*(nlat+4)) then
            ierror = 4
        else
            ierror = 0
        end if

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

        !  Compute workspace index pointers
        workspace_indices = shags_get_workspace_indices(nlat, late, ntrunc)

        associate (&
            i1 => workspace_indices(1), &
            i2 => workspace_indices(2), &
            i3 => workspace_indices(3), &
            i4 => workspace_indices(4), &
            i5 => workspace_indices(5), &
            i6 => workspace_indices(6), &
            i7 => workspace_indices(7), &
            idth => workspace_indices(8), &
            idwts => workspace_indices(9), &
            iw => workspace_indices(10) &
            )

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

        end associate

        ! Check error of lower routine call
        if (ierror /= 0) then
            ierror = 6
            return
        end if

    end subroutine shagsi_lower_utility_routine

    pure function shags_get_workspace_indices(nlat, late, l) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: late
        integer(ip), intent(in)  :: l
        integer(ip)              :: return_value(SIZE_OF_WORKSPACE_INDICES)

        associate (i => return_value)
            i(1) = 1
            i(2) = i(1)+nlat
            i(3) = i(2)+nlat*late
            i(4) = i(3)+nlat*late
            i(5) = i(4)+l*(l-1)/2 +(nlat-l)*(l-1)
            i(6) = i(5)+l*(l-1)/2 +(nlat-l)*(l-1)
            i(7) = i(6)+l*(l-1)/2 +(nlat-l)*(l-1)
            !
            !  set indices in temp work for real gaussian wts and pts
            !
            i(8) = 1
            i(9) = nlat + 1
            i(10) = 2*nlat + 1
        end associate

    end function shags_get_workspace_indices

    subroutine shagsp_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(inout)  :: p0n(nlat, late)
        real(wp),    intent(inout)  :: p1n(nlat, late)
        real(wp),    intent(inout)  :: abel(*)
        real(wp),    intent(inout)  :: bbel(*)
        real(wp),    intent(inout)  :: cbel(*)
        real(wp),    intent(inout)  :: wfft(*)
        real(wp),    intent(inout)  :: dtheta(nlat)
        real(wp),    intent(inout)  :: 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

        call util%hfft%initialize(nlon, wfft)

        !
        !  Compute real gaussian points and weights
        !    lw = 4*nlat*(nlat+2)
        lw = nlat*(nlat+2)

        call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)

        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 shagsp_lower_utility_routine

end submodule scalar_analysis_gaussian_grid_saved


C PROGRAM TO COMPUTE NODAL FACTORS AND EQUILIBRIUM ARGUEMENTS
C
C
      PARAMETER(NCNST=37)

      CHARACTER CNAME(NCNST)*8
      COMMON /CNSNAM/ CNAME
      REAL NODFAC,MONTH
      DIMENSION NCON(NCNST)
      COMMON /CNST/ NODFAC(NCNST),GRTERM(NCNST),SPEED(NCNST),P(NCNST)

      OPEN(UNIT=11,FILE='tide_fac.out',STATUS='UNKNOWN')

      WRITE(*,*) 'ENTER LENGTH OF RUN TIME (DAYS)'
      READ(*,*) XDAYS
      RHRS=XDAYS*24.

      WRITE(*,*)' ENTER START TIME - BHR,IDAY,IMO,IYR (IYR e.g. 1992)'
      READ(*,*) BHR,IDAY,IMO,IYR
      YR=IYR
      MONTH=IMO
      DAY=IDAY
      HRM=BHR+RHRS/2.
      WRITE(11,10) BHR,IDAY,IMO,IYR
      WRITE(*,10) BHR,IDAY,IMO,IYR
  10  FORMAT(' TIDAL FACTORS STARTING: ',
     &       ' HR-',F5.2,',  DAY-',I3,',  MONTH-',I3,'  YEAR-',I5,/)
      WRITE(*,11) XDAYS
      WRITE(11,11) XDAYS
  11  FORMAT(' FOR A RUN LASTING ',F8.2,' DAYS',//)

C-- DETERMINE THE JULIAN TIME AT BEGINNING AND MIDDLE OF RECORD
      DAYJ=DAYJUL(YR,MONTH,DAY)

C-- DETERMINE NODE FACTORS AT MIDDLE OF RECORD
      CALL NFACS(YR,DAYJ,HRM)

C-- DETERMINE GREENWICH EQUIL. TERMS AT BEGINNING OF RECORD
      CALL GTERMS(YR,DAYJ,BHR,DAYJ,HRM)

      NUMCON=13
      NCON(1)=4
      NCON(2)=6
      NCON(3)=30
      NCON(4)=26
      NCON(5)=3
      NCON(6)=1
      NCON(7)=2
      NCON(8)=35
      NCON(9)=24
      NCON(10)=20
      NCON(11)=5
      NCON(12)=37
      NCON(13)=10

      WRITE(11,*) 'CONST   NODE     EQ ARG (ref GM)'
      WRITE(11,1300)
 1300 FORMAT(' NAME   FACTOR    (DEG) ',//)

      DO 20 NC=1,NUMCON
        IC=NCON(NC)

C EQUILIBRIUM ARGUEMENT IS REFERENCED TO THE GRENWICH MERIDIAN

        WRITE(11,2001) CNAME(IC),NODFAC(IC),GRTERM(IC)
 2001   FORMAT(1X,A4,2x,F7.5,4x,F7.2,2x,F7.4)
   20   CONTINUE

      STOP
      END

      SUBROUTINE NFACS(YR,DAYJ,HR)

C-- CALCULATES NODE FACTORS FOR CONSTITUENT TIDAL SIGNAL

C-- THE EQUATIONS USED IN THIS ROUTINE COME FROM:
C         "MANUAL OF HARMONIC ANALYSIS AND PREDICTION OF TIDES"
C         BY PAUL SCHUREMAN, SPECIAL PUBLICATION #98, US COAST
C         AND GEODETIC SURVEY, DEPARTMENT OF COMMERCE (1958).

C-- IF DAYM AND HRM CORRESPOND TO MIDYEAR, THEN THIS ROUTINE
C-- RETURNS THE SAME VALUES AS FOUND IN TABLE 14 OF SCHUREMAN.
C---------------------------------------------------------------------

      CHARACTER*8   CST(37)
      REAL          I,N,NU

      COMMON/ORBITF/DS,DP,DH,DP1,DN,DI,DNU,DXI,DNUP,DNUP2,DPC
      COMMON/ CNST /FNDCST(37),EQCST(37),ACST(37),PCST(37)
      COMMON/CNSNAM/CST

C-- CONSTITUENT NAMES:
      DATA CST     /'M2      ','S2      ','N2      ','K1      ',
     *              'M4      ','O1      ','M6      ','MK3     ',
     *              'S4      ','MN4     ','NU2     ','S6      ',
     *              'MU2     ','2N2     ','OO1     ','LAMBDA2 ',
     *              'S1      ','M1      ','J1      ','MM      ',
     *              'SSA     ','SA      ','MSF     ','MF      ',
     *              'RHO1    ','Q1      ','T2      ','R2      ',
     *              '2Q1     ','P1      ','2SM2    ','M3      ',
     *              'L2      ','2MK3    ','K2      ','M8      ',
     *              'MS4     '/

C-- ORBITAL SPEEDS (DEGREES/HOUR):
      DATA ACST/28.9841042,30.0,28.4397295,15.0410686,57.9682084,
     *13.9430356,86.9523127,44.0251729,60.0,57.4238337,28.5125831,90.0,
     *27.9682084,27.8953548,16.1391017,29.4556253,15.0,14.4966939,
     *15.5854433,0.5443747,0.0821373,0.0410686,1.0158958,1.0980331,
     *13.4715145,13.3986609,29.9589333,30.0410667,12.8542862,14.9589314,
     *31.0158958,43.4761563,29.5284789,42.9271398,30.0821373,
     *115.9364169,58.9841042/

C-- NUMBER OF TIDE CYCLES PER DAY PER CONSTITUENT:
      DATA PCST/2.,2.,2.,1.,4.,1.,6.,3.,4.,4.,2.,6.,2.,2.,1.,2.,1.,1.,
     $1.,0.,0.,0.,0.,0.,1.,1.,2.,2.,1.,1.,2.,3.,2.,3.,2.,8.,4./

      PI180=3.14159265/180.
      CALL ORBIT(YR,DAYJ,HR)
      N=DN*PI180
      I=DI*PI180
      NU=DNU*PI180
      XI=DXI*PI180
      P=DP*PI180
      PC=DPC*PI180
      SINI=SIN(I)
      SINI2=SIN(I/2.)
      SIN2I=SIN(2.*I)
      COSI2=COS(I/2.)
      TANI2=TAN(I/2.)
C-- EQUATION 197, SCHUREMAN
      QAINV=SQRT(2.310+1.435*COS(2.*PC))
C-- EQUATION 213, SCHUREMAN
      RAINV=SQRT(1.-12.*TANI2**2*COS(2.*PC)+36.*TANI2**4)
C-- VARIABLE NAMES REFER TO EQUATION NUMBERS IN SCHUREMAN
      EQ73=(2./3.-SINI**2)/.5021
      EQ74=SINI**2/.1578
      EQ75=SINI*COSI2**2/.37988
      EQ76=SIN(2*I)/.7214
      EQ77=SINI*SINI2**2/.0164
      EQ78=(COSI2**4)/.91544
      EQ149=COSI2**6/.8758
      EQ207=EQ75*QAINV
      EQ215=EQ78*RAINV
      EQ227=SQRT(.8965*SIN2I**2+.6001*SIN2I*COS(NU)+.1006)
      EQ235=.001+SQRT(19.0444*SINI**4+2.7702*SINI**2*COS(2.*NU)+.0981)
C-- NODE FACTORS FOR 37 CONSTITUENTS:
      FNDCST(1)=EQ78
      FNDCST(2)=1.0
      FNDCST(3)=EQ78
      FNDCST(4)=EQ227
      FNDCST(5)=FNDCST(1)**2
      FNDCST(6)=EQ75
      FNDCST(7)=FNDCST(1)**3
      FNDCST(8)=FNDCST(1)*FNDCST(4)
      FNDCST(9)=1.0
      FNDCST(10)=FNDCST(1)**2
      FNDCST(11)=EQ78
      FNDCST(12)=1.0
      FNDCST(13)=EQ78
      FNDCST(14)=EQ78
      FNDCST(15)=EQ77
      FNDCST(16)=EQ78
      FNDCST(17)=1.0
C** EQUATION 207 NOT PRODUCING CORRECT ANSWER FOR M1
C**SET NODE FACTOR FOR M1 = 0 UNTIL CAN FURTHER RESEARCH
      FNDCST(18)=0.
C     FNDCST(18)=EQ207
      FNDCST(19)=EQ76
      FNDCST(20)=EQ73
      FNDCST(21)=1.0
      FNDCST(22)=1.0
      FNDCST(23)=EQ78
      FNDCST(24)=EQ74
      FNDCST(25)=EQ75
      FNDCST(26)=EQ75
      FNDCST(27)=1.0
      FNDCST(28)=1.0
      FNDCST(29)=EQ75
      FNDCST(30)=1.0
      FNDCST(31)=EQ78
      FNDCST(32)=EQ149
C** EQUATION 215 NOT PRODUCING CORRECT ANSWER FOR L2
C** SET NODE FACTOR FOR L2 = 0 UNTIL CAN FURTHER RESEARCH
      FNDCST(33)=0.
C     FNDCST(33)=EQ215
      FNDCST(34)=FNDCST(1)**2*FNDCST(4)
      FNDCST(35)=EQ235
      FNDCST(36)=FNDCST(1)**4
      FNDCST(37)=EQ78
      END

      SUBROUTINE GTERMS(YR,DAYJ,HR,DAYM,HRM)
C-- CALCULATES EQUILIBRIUM ARGUMENTS V0+U FOR CONSTITUENT TIDE

C-- THE EQUATIONS USED IN THIS ROUTINE COME FROM:
C         "MANUAL OF HARMONIC ANALYSIS AND PREDICTION OF TIDES"
C         BY PAUL SCHUREMAN, SPECIAL PUBLICATION #98, US COAST
C         AND GEODETIC SURVEY, DEPARTMENT OF COMMERCE (1958).

C-- IF DAYM AND HRM CORRESPOND TO MIDYEAR, THEN THIS ROUTINE
C-- RETURNS THE SAME VALUES AS FOUND IN TABLE 15 OF SCHUREMAN.
C---------------------------------------------------------------------
      REAL NU,NUP,NUP2,I
      COMMON /ORBITF/DS,DP,DH,DP1,DN,DI,DNU,DXI,DNUP,DNUP2,DPC
      COMMON /CNST/ FNDCST(37),EQCST(37),ACST(37),PCST(37)
      PI180=3.14159265/180.
C* OBTAINING ORBITAL VALUES AT BEGINNING OF SERIES FOR V0
      CALL ORBIT(YR,DAYJ,HR)
      S=DS
      P=DP
      H=DH
      P1=DP1
      T=ANGLE(180.+HR*(360./24.))
C** OBTAINING ORBITAL VALUES AT MIDDLE OF SERIES FOR U
      CALL ORBIT(YR,DAYM,HRM)
      NU=DNU
      XI=DXI
      NUP=DNUP
      NUP2=DNUP2
C* SUMMING TERMS TO OBTAIN EQUILIBRIUM ARGUMENTS
      EQCST(1)=2.*(T-S+H)+2.*(XI-NU)
      EQCST(2)=2.*T
      EQCST(3)=2.*(T+H)-3.*S+P+2.*(XI-NU)
      EQCST(4)=T+H-90.-NUP
      EQCST(5)=4.*(T-S+H)+4.*(XI-NU)
      EQCST(6)=T-2.*S+H+90.+2.*XI-NU
      EQCST(7)=6.*(T-S+H)+6.*(XI-NU)
      EQCST(8)=3.*(T+H)-2.*S-90.+2.*(XI-NU)-NUP
      EQCST(9)=4.*T
      EQCST(10)=4.*(T+H)-5.*S+P+4.*(XI-NU)
      EQCST(11)=2.*T-3.*S+4.*H-P+2.*(XI-NU)
      EQCST(12)=6.*T
      EQCST(13)=2.*(T+2.*(H-S))+2.*(XI-NU)
      EQCST(14)=2.*(T-2.*S+H+P)+2.*(XI-NU)
      EQCST(15)=T+2.*S+H-90.-2.*XI-NU
      EQCST(16)=2.*T-S+P+180.+2.*(XI-NU)
      EQCST(17)=T
      I=DI*PI180
      PC=DPC*PI180
      TOP=(5.*COS(I)-1.)*SIN(PC)
      BOTTOM=(7.*COS(I)+1.)*COS(PC)
      Q=ARCTAN(TOP,BOTTOM,1)
      EQCST(18)=T-S+H-90.+XI-NU+Q
      EQCST(19)=T+S+H-P-90.-NU
      EQCST(20)=S-P
      EQCST(21)=2.*H
      EQCST(22)=H
      EQCST(23)=2.*(S-H)
      EQCST(24)=2.*S-2.*XI
      EQCST(25)=T+3.*(H-S)-P+90.+2.*XI-NU
      EQCST(26)=T-3.*S+H+P+90.+2.*XI-NU
      EQCST(27)=2.*T-H+P1
      EQCST(28)=2.*T+H-P1+180.
      EQCST(29)=T-4.*S+H+2.*P+90.+2.*XI-NU
      EQCST(30)=T-H+90.
      EQCST(31)=2.*(T+S-H)+2.*(NU-XI)
      EQCST(32)=3.*(T-S+H)+3.*(XI-NU)
      R=SIN(2.*PC)/((1./6.)*(1./TAN(.5*I))**2-COS(2.*PC))
      R=ATAN(R)/PI180
      EQCST(33)=2.*(T+H)-S-P+180.+2.*(XI-NU)-R
      EQCST(34)=3.*(T+H)-4.*S+90.+4.*(XI-NU)+NUP
      EQCST(35)=2.*(T+H)-2.*NUP2
      EQCST(36)=8.*(T-S+H)+8.*(XI-NU)
      EQCST(37)=2.*(2.*T-S+H)+2.*(XI-NU)
      DO 1 IH=1,37
    1 EQCST(IH)=ANGLE(EQCST(IH))
      END

      SUBROUTINE ORBIT(YR,DAYJ,HR)

C-- DETERMINATION OF PRIMARY AND SECONDARY ORBITAL FUNCTIONS

C-- THE EQUATIONS PROGRAMMED HERE ARE NOT REPRESENTED BY EQUATIONS IN
C   SCHUREMAN.  THE CODING IN THIS ROUTINE DERIVES FROM A PROGRAM BY
C   THE NATIONAL OCEANIC AND ATMOSPHERIC ADMINISTRATION (NOAA).
C   HOWEVER, TABULAR VALUES OF THE ORBITAL FUNCTIONS CAN BE FOUND IN
C   TABLE 1 OF SCHUREMAN.

C---------------------------------------------------------------------
      REAL I,N,NU,NUP,NUP2
      COMMON /ORBITF/DS,DP,DH,DP1,DN,DI,DNU,DXI,DNUP,DNUP2,DPC

      PI180=3.14159265/180.
      X=AINT((YR-1901.)/4.)
      DYR=YR-1900.
      DDAY=DAYJ+X-1.
C-- DN IS THE MOON'S NODE (CAPITAL N, TABLE 1, SCHUREMAN)
      DN=259.1560564-19.328185764*DYR-.0529539336*DDAY-.0022064139*HR
      DN=ANGLE(DN)
      N=DN*PI180
C-- DP IS THE LUNAR PERIGEE (SMALL P, TABLE 1)
      DP=334.3837214+40.66246584*DYR+.111404016*DDAY+.004641834*HR
      DP=ANGLE(DP)
      P=DP*PI180
      I=ACOS(.9136949-.0356926*COS(N))
      DI=ANGLE(I/PI180)
      NU=ASIN(.0897056*SIN(N)/SIN(I))
      DNU=NU/PI180
      XI=N-2.*ATAN(.64412*TAN(N/2.))-NU
      DXI=XI/PI180
      DPC=ANGLE(DP-DXI)
C-- DH IS THE MEAN LONGITUDE OF THE SUN (SMALL H, TABLE 1)
      DH=280.1895014-.238724988*DYR+.9856473288*DDAY+.0410686387*HR
      DH=ANGLE(DH)
C-- DP1 IS THE SOLAR PERIGEE (SMALL P1, TABLE 1)
      DP1=281.2208569+.01717836*DYR+.000047064*DDAY+.000001961*HR
      DP1=ANGLE(DP1)
C-- DS IS THE MEAN LONGITUDE OF THE MOON (SMALL S, TABLE 1)
      DS=277.0256206+129.38482032*DYR+13.176396768*DDAY+.549016532*HR
      DS=ANGLE(DS)
      NUP=ATAN(SIN(NU)/(COS(NU)+.334766/SIN(2.*I)))
      DNUP=NUP/PI180
      NUP2=ATAN(SIN(2.*NU)/(COS(2.*NU)+.0726184/SIN(I)**2))/2.
      DNUP2=NUP2/PI180
      END

      FUNCTION ANGLE(ARG)
C
C*** THIS ROUTINE PLACES AN ANGLE IN 0-360 (+) FORMAT
C
      M=-IFIX(ARG/360.)
      ANGLE=ARG+FLOAT(M)*360.
      IF(ANGLE .LT. 0.) ANGLE=ANGLE+360.
      END
      FUNCTION ARCTAN(TOP,BOTTOM,KEY)
C** DETERMINE ARCTANGENT AND PLACE IN CORRECT QUADRANT
C   IF KEY EQ 0  NO QUADRANT SELECTION MADE
C   IF KEY .NE. 0 PROPER QUADRANT IS SELECTED

      IF(BOTTOM .NE. 0.0) GO TO 4
      IF(TOP) 2,9,3
    2 ARCTAN=270.
      RETURN
    3 ARCTAN=90.
      RETURN
    4 ARCTAN=ATAN(TOP/BOTTOM)*57.2957795
      IF(KEY.EQ.0) RETURN
      IF(TOP) 5,5,7
    5 IF(BOTTOM) 6,9,8
    6 ARCTAN=ARCTAN+180.
      RETURN
    7 IF(BOTTOM) 6,3,10
    8 ARCTAN=ARCTAN+360.
      RETURN
    9 ARCTAN=0.
   10 RETURN
      END

      FUNCTION DAYJUL(YR,XMONTH,DAY)
C
C*** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE)
C
      DIMENSION DAYT(12),DAYS(12)
      DATA DAYT/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./
      DATA DAYS(1),DAYS(2) /0.,31./
      DINC=0.
      YRLP=MOD((YR-1900.),4.)
      IF(YRLP .EQ. 0.) DINC=1.
      DO 1 I=3,12
    1 DAYS(I)=DAYT(I)+DINC
      DAYJUL=DAYS(IFIX(XMONTH))+DAY
      END


      SUBROUTINE ROTATE_X(RX,RY,RZ,O)

      include 'trigd.inc'

      RY1 = RY
      RZ1 = RZ
      RY=RY1*COSD(O)-RZ1*SIND(O)
      RZ=RY1*SIND(O)+RZ1*COSD(O)

      RETURN
      END

      SUBROUTINE ROTATE_Y(RX,RY,RZ,O)

      include 'trigd.inc'

      RZ1 = RZ
      RX1 = RX
      RZ=RZ1*COSD(O)-RX1*SIND(O)
      RX=RZ1*SIND(O)+RZ1*COSD(O)

      RETURN
      END

      SUBROUTINE ROTATE_Z(RX,RY,RZ,O)

      include 'trigd.inc'

      RX1 = RX
      RY1 = RY
      RX=RX1*COSD(O)-RY1*SIND(O)
      RY=RX1*SIND(O)+RY1*COSD(O)

      RETURN
      END


	FUNCTION YMAG2(WL,F,NI)

c	Computes Mg2 Index defined by Burstein, Faber, et al.
c	Written by G. Magris (May 1991)

	real wl(ni),f(ni),w0(6),wc(3),fl(200),wi(200),fi(3),wn(200),delta(3)
	real linear
	data nw,w0/3,4897.,4958.25,5156.,5197.25,5303.,5366.75/

	ymag2=0.

	wc(1)=(w0(1)+w0(2))/2.
	wc(3)=(w0(5)+w0(6))/2.
	wc(2)=(w0(3)+w0(4))/2.
	delta(1)=w0(2)-w0(1)
	delta(3)=w0(6)-w0(5)
	delta(2)=w0(4)-w0(3)

	np=21
	do j=1,3
	k=2*j-1
	del=(w0(k+1)-w0(k))/np
		do i=1,np+1
		l=i+(np+1)*(j-1)
		wi(l)=w0(k)+del*(i-1)
		enddo
	enddo

	do j=1,3
		i0=0
		do i=1,np+1
		l=i+(np+1)*(j-1)
		wn(i)=wi(l)
		fl(i)= linear(wi(l),wl,f,ni,i0)
		enddo
	fi(j)=trapz1(wn,fl,np+1)/delta(j)
	enddo

	fc=fi(1)+(fi(3)-fi(1))/(wc(3)-wc(1))*(wc(2)-wc(1))
	ymag2=-2.5*alog10(fi(2)/fc)

	return
	end


module mod_eigenvalues
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ONE

    use mod_inv,    only: inv

    implicit none

    ! External procedures defined in LAPACK
    external DGETRI
    external DGETRF
    external DGECON
    external DLANGE
    external DGEEV
    real(rk) :: DLANGE

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/17/2016
    !!
    !!  TODO: Try to find URL for citation.
    !!
    !---------------------------------------------------------------------------
    subroutine eigenvalues(A,wr,wi)
        real(rk), dimension(:,:), intent(in)    :: A
        real(rk), dimension(:),   intent(inout) :: wr, wi
        real(rk), dimension(size(A,1),size(A,2)) :: Acopy

        real(rk), dimension(size(A,1)*4)   :: work    ! work array for LAPACK
        real(rk), dimension(size(A,1),size(A,2)) :: junk
        integer :: n, info, nwork

        !
        ! Store A in Acopy to prevent it from being overwritten by LAPACK
        !
        Acopy = A
        n = size(A,1)
        nwork = size(work,1)

        !
        ! Estimate eigenvalues
        !
        call DGEEV('N','N',n, Acopy, n, wr, wi, junk, n, junk, n, work, nwork, info)
        print*, 'eigenvalues DGEEV info ', info

    end subroutine eigenvalues
    !******************************************************************************

end module mod_eigenvalues


      SUBROUTINE CALCEI(ARG,RESULT,INT)
C----------------------------------------------------------------------
C
C This Fortran 77 packet computes the exponential integrals Ei(x),
C  E1(x), and  exp(-x)*Ei(x)  for real arguments  x  where
C
C           integral (from t=-infinity to t=x) (exp(t)/t),  x > 0,
C  Ei(x) =
C          -integral (from t=-x to t=infinity) (exp(t)/t),  x < 0,
C
C  and where the first integral is a principal value integral.
C  The packet contains three function type subprograms: EI, EONE,
C  and EXPEI;  and one subroutine type subprogram: CALCEI.  The
C  calling statements for the primary entries are
C
C                 Y = EI(X),            where  X .NE. 0,
C
C                 Y = EONE(X),          where  X .GT. 0,
C  and
C                 Y = EXPEI(X),         where  X .NE. 0,
C
C  and where the entry points correspond to the functions Ei(x),
C  E1(x), and exp(-x)*Ei(x), respectively.  The routine CALCEI
C  is intended for internal packet use only, all computations within
C  the packet being concentrated in this routine.  The function
C  subprograms invoke CALCEI with the Fortran statement
C         CALL CALCEI(ARG,RESULT,INT)
C  where the parameter usage is as follows
C
C     Function                  Parameters for CALCEI
C       Call                 ARG             RESULT         INT
C
C      EI(X)              X .NE. 0          Ei(X)            1
C      EONE(X)            X .GT. 0         -Ei(-X)           2
C      EXPEI(X)           X .NE. 0          exp(-X)*Ei(X)    3
C
C  The main computation involves evaluation of rational Chebyshev
C  approximations published in Math. Comp. 22, 641-649 (1968), and
C  Math. Comp. 23, 289-303 (1969) by Cody and Thacher.  This
C  transportable program is patterned after the machine-dependent
C  FUNPACK packet  NATSEI,  but cannot match that version for
C  efficiency or accuracy.  This version uses rational functions
C  that theoretically approximate the exponential integrals to
C  at least 18 significant decimal digits.  The accuracy achieved
C  depends on the arithmetic system, the compiler, the intrinsic
C  functions, and proper selection of the machine-dependent
C  constants.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta = radix for the floating-point system.
C   minexp = smallest representable power of beta.
C   maxexp = smallest power of beta that overflows.
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XBIG = largest argument acceptable to EONE; solution to
C          equation:
C                     exp(-x)/x * (1 + 1/x) = beta ** minexp.
C   XINF = largest positive machine number; approximately
C                     beta ** maxexp
C   XMAX = largest argument acceptable to EI; solution to
C          equation:  exp(x)/x * (1 + 1/x) = beta ** maxexp.
C
C     Approximate values for some important machines are:
C
C                           beta      minexp      maxexp
C
C  CRAY-1        (S.P.)       2       -8193        8191
C  Cyber 180/185
C    under NOS   (S.P.)       2        -975        1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2        -126         128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2       -1022        1024
C  IBM 3033      (D.P.)      16         -65          63
C  VAX D-Format  (D.P.)       2        -128         127
C  VAX G-Format  (D.P.)       2       -1024        1023
C
C                           XBIG       XINF       XMAX
C
C  CRAY-1        (S.P.)    5670.31  5.45E+2465   5686.21
C  Cyber 180/185
C    under NOS   (S.P.)     669.31  1.26E+322     748.28
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)      82.93  3.40E+38       93.24
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)     701.84  1.79D+308     716.35
C  IBM 3033      (D.P.)     175.05  7.23D+75      179.85
C  VAX D-Format  (D.P.)      84.30  1.70D+38       92.54
C  VAX G-Format  (D.P.)     703.22  8.98D+307     715.66
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The following table shows the types of error that may be
C  encountered in this routine and the function value supplied
C  in each case.
C
C       Error       Argument         Function values for
C                    Range         EI      EXPEI     EONE
C
C     UNDERFLOW  (-)X .GT. XBIG     0        -         0
C     OVERFLOW      X .GE. XMAX    XINF      -         -
C     ILLEGAL X       X = 0       -XINF    -XINF     XINF
C     ILLEGAL X      X .LT. 0       -        -     USE ABS(X)
C
C Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Author: W. J. Cody
C          Mathematics abd Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 9, 1992
C
C----------------------------------------------------------------------
      INTEGER I,INT
CS    REAL
      DOUBLE PRECISION
     1       A,ARG,B,C,D,EXP40,E,EI,F,FOUR,FOURTY,FRAC,HALF,ONE,P,
     2       PLG,PX,P037,P1,P2,Q,QLG,QX,Q1,Q2,R,RESULT,S,SIX,SUMP,
     3       SUMQ,T,THREE,TWELVE,TWO,TWO4,W,X,XBIG,XINF,XMAX,XMX0,
     4       X0,X01,X02,X11,Y,YSQ,ZERO
      DIMENSION  A(7),B(6),C(9),D(9),E(10),F(10),P(10),Q(10),R(10),
     1   S(9),P1(10),Q1(9),P2(10),Q2(9),PLG(4),QLG(4),PX(10),QX(10)
C----------------------------------------------------------------------
C  Mathematical constants
C   EXP40 = exp(40)
C   X0 = zero of Ei
C   X01/X11 + X02 = zero of Ei to extra precision
C----------------------------------------------------------------------
CS    DATA ZERO,P037,HALF,ONE,TWO/0.0E0,0.037E0,0.5E0,1.0E0,2.0E0/,
CS   1     THREE,FOUR,SIX,TWELVE,TWO4/3.0E0,4.0E0,6.0E0,12.E0,24.0E0/,
CS   2     FOURTY,EXP40/40.0E0,2.3538526683701998541E17/,
CS   3     X01,X11,X02/381.5E0,1024.0E0,-5.1182968633365538008E-5/,
CS   4     X0/3.7250741078136663466E-1/
      DATA ZERO,P037,HALF,ONE,TWO/0.0D0,0.037D0,0.5D0,1.0D0,2.0D0/,
     1     THREE,FOUR,SIX,TWELVE,TWO4/3.0D0,4.0D0,6.0D0,12.D0,24.0D0/,
     2     FOURTY,EXP40/40.0D0,2.3538526683701998541D17/,
     3     X01,X11,X02/381.5D0,1024.0D0,-5.1182968633365538008D-5/,
     4     X0/3.7250741078136663466D-1/
C----------------------------------------------------------------------
C Machine-dependent constants
C----------------------------------------------------------------------
CS    DATA XINF/3.40E+38/,XMAX/93.246E0/,XBIG/82.93E0/
      DATA XINF/1.79D+308/,XMAX/716.351D0/,XBIG/701.84D0/
C----------------------------------------------------------------------
C Coefficients  for -1.0 <= X < 0.0
C----------------------------------------------------------------------
CS    DATA A/1.1669552669734461083368E2, 2.1500672908092918123209E3,
CS   1       1.5924175980637303639884E4, 8.9904972007457256553251E4,
CS   2       1.5026059476436982420737E5,-1.4815102102575750838086E5,
CS   3       5.0196785185439843791020E0/
CS    DATA B/4.0205465640027706061433E1, 7.5043163907103936624165E2,
CS   1       8.1258035174768735759855E3, 5.2440529172056355429883E4,
CS   2       1.8434070063353677359298E5, 2.5666493484897117319268E5/
      DATA A/1.1669552669734461083368D2, 2.1500672908092918123209D3,
     1       1.5924175980637303639884D4, 8.9904972007457256553251D4,
     2       1.5026059476436982420737D5,-1.4815102102575750838086D5,
     3       5.0196785185439843791020D0/
      DATA B/4.0205465640027706061433D1, 7.5043163907103936624165D2,
     1       8.1258035174768735759855D3, 5.2440529172056355429883D4,
     2       1.8434070063353677359298D5, 2.5666493484897117319268D5/
C----------------------------------------------------------------------
C Coefficients for -4.0 <= X < -1.0
C----------------------------------------------------------------------
CS    DATA C/3.828573121022477169108E-1, 1.107326627786831743809E+1,
CS   1       7.246689782858597021199E+1, 1.700632978311516129328E+2,
CS   2       1.698106763764238382705E+2, 7.633628843705946890896E+1,
CS   3       1.487967702840464066613E+1, 9.999989642347613068437E-1,
CS   4       1.737331760720576030932E-8/
CS    DATA D/8.258160008564488034698E-2, 4.344836335509282083360E+0,
CS   1       4.662179610356861756812E+1, 1.775728186717289799677E+2,
CS   2       2.953136335677908517423E+2, 2.342573504717625153053E+2,
CS   3       9.021658450529372642314E+1, 1.587964570758947927903E+1,
CS   4       1.000000000000000000000E+0/
      DATA C/3.828573121022477169108D-1, 1.107326627786831743809D+1,
     1       7.246689782858597021199D+1, 1.700632978311516129328D+2,
     2       1.698106763764238382705D+2, 7.633628843705946890896D+1,
     3       1.487967702840464066613D+1, 9.999989642347613068437D-1,
     4       1.737331760720576030932D-8/
      DATA D/8.258160008564488034698D-2, 4.344836335509282083360D+0,
     1       4.662179610356861756812D+1, 1.775728186717289799677D+2,
     2       2.953136335677908517423D+2, 2.342573504717625153053D+2,
     3       9.021658450529372642314D+1, 1.587964570758947927903D+1,
     4       1.000000000000000000000D+0/
C----------------------------------------------------------------------
C Coefficients for X < -4.0
C----------------------------------------------------------------------
CS    DATA E/1.3276881505637444622987E+2,3.5846198743996904308695E+4,
CS   1       1.7283375773777593926828E+5,2.6181454937205639647381E+5,
CS   2       1.7503273087497081314708E+5,5.9346841538837119172356E+4,
CS   3       1.0816852399095915622498E+4,1.0611777263550331766871E03,
CS   4       5.2199632588522572481039E+1,9.9999999999999999087819E-1/
CS    DATA F/3.9147856245556345627078E+4,2.5989762083608489777411E+5,
CS   1       5.5903756210022864003380E+5,5.4616842050691155735758E+5,
CS   2       2.7858134710520842139357E+5,7.9231787945279043698718E+4,
CS   3       1.2842808586627297365998E+4,1.1635769915320848035459E+3,
CS   4       5.4199632588522559414924E+1,1.0E0/
      DATA E/1.3276881505637444622987D+2,3.5846198743996904308695D+4,
     1       1.7283375773777593926828D+5,2.6181454937205639647381D+5,
     2       1.7503273087497081314708D+5,5.9346841538837119172356D+4,
     3       1.0816852399095915622498D+4,1.0611777263550331766871D03,
     4       5.2199632588522572481039D+1,9.9999999999999999087819D-1/
      DATA F/3.9147856245556345627078D+4,2.5989762083608489777411D+5,
     1       5.5903756210022864003380D+5,5.4616842050691155735758D+5,
     2       2.7858134710520842139357D+5,7.9231787945279043698718D+4,
     3       1.2842808586627297365998D+4,1.1635769915320848035459D+3,
     4       5.4199632588522559414924D+1,1.0D0/
C----------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a), |1-x/a| < .1
C----------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
      DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
     1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
      DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
     1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C----------------------------------------------------------------------
C Coefficients for  0.0 < X < 6.0,
C  ratio of Chebyshev polynomials
C----------------------------------------------------------------------
CS    DATA P/-1.2963702602474830028590E01,-1.2831220659262000678155E03,
CS   1       -1.4287072500197005777376E04,-1.4299841572091610380064E06,
CS   2       -3.1398660864247265862050E05,-3.5377809694431133484800E08,
CS   3        3.1984354235237738511048E08,-2.5301823984599019348858E10,
CS   4        1.2177698136199594677580E10,-2.0829040666802497120940E11/
CS    DATA Q/ 7.6886718750000000000000E01,-5.5648470543369082846819E03,
CS   1        1.9418469440759880361415E05,-4.2648434812177161405483E06,
CS   2        6.4698830956576428587653E07,-7.0108568774215954065376E08,
CS   3        5.4229617984472955011862E09,-2.8986272696554495342658E10,
CS   4        9.8900934262481749439886E10,-8.9673749185755048616855E10/
      DATA P/-1.2963702602474830028590D01,-1.2831220659262000678155D03,
     1       -1.4287072500197005777376D04,-1.4299841572091610380064D06,
     2       -3.1398660864247265862050D05,-3.5377809694431133484800D08,
     3        3.1984354235237738511048D08,-2.5301823984599019348858D10,
     4        1.2177698136199594677580D10,-2.0829040666802497120940D11/
      DATA Q/ 7.6886718750000000000000D01,-5.5648470543369082846819D03,
     1        1.9418469440759880361415D05,-4.2648434812177161405483D06,
     2        6.4698830956576428587653D07,-7.0108568774215954065376D08,
     3        5.4229617984472955011862D09,-2.8986272696554495342658D10,
     4        9.8900934262481749439886D10,-8.9673749185755048616855D10/
C----------------------------------------------------------------------
C J-fraction coefficients for 6.0 <= X < 12.0
C----------------------------------------------------------------------
CS    DATA R/-2.645677793077147237806E00,-2.378372882815725244124E00,
CS   1       -2.421106956980653511550E01, 1.052976392459015155422E01,
CS   2        1.945603779539281810439E01,-3.015761863840593359165E01,
CS   3        1.120011024227297451523E01,-3.988850730390541057912E00,
CS   4        9.565134591978630774217E00, 9.981193787537396413219E-1/
CS    DATA S/ 1.598517957704779356479E-4, 4.644185932583286942650E00,
CS   1        3.697412299772985940785E02,-8.791401054875438925029E00,
CS   2        7.608194509086645763123E02, 2.852397548119248700147E01,
CS   3        4.731097187816050252967E02,-2.369210235636181001661E02,
CS   4        1.249884822712447891440E00/
      DATA R/-2.645677793077147237806D00,-2.378372882815725244124D00,
     1       -2.421106956980653511550D01, 1.052976392459015155422D01,
     2        1.945603779539281810439D01,-3.015761863840593359165D01,
     3        1.120011024227297451523D01,-3.988850730390541057912D00,
     4        9.565134591978630774217D00, 9.981193787537396413219D-1/
      DATA S/ 1.598517957704779356479D-4, 4.644185932583286942650D00,
     1        3.697412299772985940785D02,-8.791401054875438925029D00,
     2        7.608194509086645763123D02, 2.852397548119248700147D01,
     3        4.731097187816050252967D02,-2.369210235636181001661D02,
     4        1.249884822712447891440D00/
C----------------------------------------------------------------------
C J-fraction coefficients for 12.0 <= X < 24.0
C----------------------------------------------------------------------
CS    DATA P1/-1.647721172463463140042E00,-1.860092121726437582253E01,
CS   1        -1.000641913989284829961E01,-2.105740799548040450394E01,
CS   2        -9.134835699998742552432E-1,-3.323612579343962284333E01,
CS   3         2.495487730402059440626E01, 2.652575818452799819855E01,
CS   4        -1.845086232391278674524E00, 9.999933106160568739091E-1/
CS    DATA Q1/ 9.792403599217290296840E01, 6.403800405352415551324E01,
CS   1         5.994932325667407355255E01, 2.538819315630708031713E02,
CS   2         4.429413178337928401161E01, 1.192832423968601006985E03,
CS   3         1.991004470817742470726E02,-1.093556195391091143924E01,
CS   4         1.001533852045342697818E00/
      DATA P1/-1.647721172463463140042D00,-1.860092121726437582253D01,
     1        -1.000641913989284829961D01,-2.105740799548040450394D01,
     2        -9.134835699998742552432D-1,-3.323612579343962284333D01,
     3         2.495487730402059440626D01, 2.652575818452799819855D01,
     4        -1.845086232391278674524D00, 9.999933106160568739091D-1/
      DATA Q1/ 9.792403599217290296840D01, 6.403800405352415551324D01,
     1         5.994932325667407355255D01, 2.538819315630708031713D02,
     2         4.429413178337928401161D01, 1.192832423968601006985D03,
     3         1.991004470817742470726D02,-1.093556195391091143924D01,
     4         1.001533852045342697818D00/
C----------------------------------------------------------------------
C J-fraction coefficients for  X .GE. 24.0
C----------------------------------------------------------------------
CS    DATA P2/ 1.75338801265465972390E02,-2.23127670777632409550E02,
CS   1        -1.81949664929868906455E01,-2.79798528624305389340E01,
CS   2        -7.63147701620253630855E00,-1.52856623636929636839E01,
CS   3        -7.06810977895029358836E00,-5.00006640413131002475E00,
CS   4        -3.00000000320981265753E00, 1.00000000000000485503E00/
CS    DATA Q2/ 3.97845977167414720840E04, 3.97277109100414518365E00,
CS   1         1.37790390235747998793E02, 1.17179220502086455287E02,
CS   2         7.04831847180424675988E01,-1.20187763547154743238E01,
CS   3        -7.99243595776339741065E00,-2.99999894040324959612E00,
CS   4         1.99999999999048104167E00/
      DATA P2/ 1.75338801265465972390D02,-2.23127670777632409550D02,
     1        -1.81949664929868906455D01,-2.79798528624305389340D01,
     2        -7.63147701620253630855D00,-1.52856623636929636839D01,
     3        -7.06810977895029358836D00,-5.00006640413131002475D00,
     4        -3.00000000320981265753D00, 1.00000000000000485503D00/
      DATA Q2/ 3.97845977167414720840D04, 3.97277109100414518365D00,
     1         1.37790390235747998793D02, 1.17179220502086455287D02,
     2         7.04831847180424675988D01,-1.20187763547154743238D01,
     3        -7.99243595776339741065D00,-2.99999894040324959612D00,
     4         1.99999999999048104167D00/
C----------------------------------------------------------------------
      X = ARG
      IF (X .EQ. ZERO) THEN
            EI = -XINF
            IF (INT .EQ. 2) EI = -EI
         ELSE IF ((X .LT. ZERO) .OR. (INT .EQ. 2)) THEN
C----------------------------------------------------------------------
C Calculate EI for negative argument or for E1.
C----------------------------------------------------------------------
            Y = ABS(X)
            IF (Y .LE. ONE) THEN
                  SUMP = A(7) * Y + A(1)
                  SUMQ = Y + B(1)
                  DO 110 I = 2, 6
                     SUMP = SUMP * Y + A(I)
                     SUMQ = SUMQ * Y + B(I)
  110             CONTINUE
                  EI = LOG(Y) - SUMP / SUMQ
                  IF (INT .EQ. 3) EI = EI * EXP(Y)
               ELSE IF (Y .LE. FOUR) THEN
                  W = ONE / Y
                  SUMP = C(1)
                  SUMQ = D(1)
                  DO 130 I = 2, 9
                     SUMP = SUMP * W + C(I)
                     SUMQ = SUMQ * W + D(I)
  130             CONTINUE
                  EI = - SUMP / SUMQ
                  IF (INT .NE. 3) EI = EI * EXP(-Y)
               ELSE
                  IF ((Y .GT. XBIG) .AND. (INT .LT. 3)) THEN
                        EI = ZERO
                     ELSE
                        W = ONE / Y
                        SUMP = E(1)
                        SUMQ = F(1)
                        DO 150 I = 2, 10
                           SUMP = SUMP * W + E(I)
                           SUMQ = SUMQ * W + F(I)
  150                   CONTINUE
                        EI = -W * (ONE - W * SUMP / SUMQ )
                        IF (INT .NE. 3) EI = EI * EXP(-Y)
                  END IF
            END IF
            IF (INT .EQ. 2) EI = -EI
         ELSE IF (X .LT. SIX) THEN
C----------------------------------------------------------------------
C  To improve conditioning, rational approximations are expressed
C    in terms of Chebyshev polynomials for 0 <= X < 6, and in
C    continued fraction form for larger X.
C----------------------------------------------------------------------
            T = X + X
            T = T / THREE - TWO
            PX(1) = ZERO
            QX(1) = ZERO
            PX(2) = P(1)
            QX(2) = Q(1)
            DO 210 I = 2, 9
               PX(I+1) = T * PX(I) - PX(I-1) + P(I)
               QX(I+1) = T * QX(I) - QX(I-1) + Q(I)
  210       CONTINUE
            SUMP = HALF * T * PX(10) - PX(9) + P(10)
            SUMQ = HALF * T * QX(10) - QX(9) + Q(10)
            FRAC = SUMP / SUMQ
            XMX0 = (X - X01/X11) - X02
            IF (ABS(XMX0) .GE. P037) THEN
                  EI = LOG(X/X0) + XMX0 * FRAC
                  IF (INT .EQ. 3) EI = EXP(-X) * EI
               ELSE
C----------------------------------------------------------------------
C Special approximation to  ln(X/X0)  for X close to X0
C----------------------------------------------------------------------
                  Y = XMX0 / (X + X0)
                  YSQ = Y*Y
                  SUMP = PLG(1)
                  SUMQ = YSQ + QLG(1)
                  DO 220 I = 2, 4
                     SUMP = SUMP*YSQ + PLG(I)
                     SUMQ = SUMQ*YSQ + QLG(I)
  220             CONTINUE
                  EI = (SUMP / (SUMQ*(X+X0)) + FRAC) * XMX0
                  IF (INT .EQ. 3) EI = EXP(-X) * EI
            END IF
         ELSE IF (X .LT. TWELVE) THEN
            FRAC = ZERO
            DO 230 I = 1, 9
               FRAC = S(I) / (R(I) + X + FRAC)
  230       CONTINUE
            EI = (R(10) + FRAC) / X
            IF (INT .NE. 3) EI = EI * EXP(X)
         ELSE IF (X .LE. TWO4) THEN
            FRAC = ZERO
            DO 240 I = 1, 9
               FRAC = Q1(I) / (P1(I) + X + FRAC)
  240       CONTINUE
            EI = (P1(10) + FRAC) / X
            IF (INT .NE. 3) EI = EI * EXP(X)
         ELSE
            IF ((X .GE. XMAX) .AND. (INT .LT. 3)) THEN
                  EI = XINF
               ELSE
                  Y = ONE / X
                  FRAC = ZERO
                  DO 250 I = 1, 9
                     FRAC = Q2(I) / (P2(I) + X + FRAC)
  250             CONTINUE
                  FRAC = P2(10) + FRAC
                  EI = Y + Y * Y * FRAC
                  IF (INT .NE. 3) THEN
                        IF (X .LE. XMAX-TWO4) THEN
                              EI = EI * EXP(X)
                           ELSE
C----------------------------------------------------------------------
C Calculation reformulated to avoid premature overflow
C----------------------------------------------------------------------
                              EI = (EI * EXP(X-FOURTY)) * EXP40
                        END IF
                  END IF
            END IF
      END IF
      RESULT = EI
      RETURN
C---------- Last line of CALCEI ----------
      END


!=======================================================================
!			Pablo Ouro Barba
!			Cardiff 2013-2014
!=======================================================================
!######################################################################
       Double precision function spline_33(r)	!Gil JCP 2013
!######################################################################
      implicit none
       Double precision, intent(in) :: r

      IF (r .le. -3.0D0) THEN
        spline_33 = 0.D0
      ELSE IF ((r.gt. -3.0D0).and.(r.le. -2.0D0)) THEN
        spline_33 =
     &   -29.d0/7560.d0*r**7 -5.d0/72.d0*r**6 -21.d0/40.d0*r**5
     &   -17.d0/8.d0*r**4    -39.d0/8.d0*r**3 -243.d0/40.d0*r**2
     &   -27.d0/8.d0*r       -81.d0/280.d0
      ELSE IF ((r.gt. -2.0D0).and.(r.le. -1.0D0)) THEN
        spline_33 =
     &    17.d0/1512.d0*r**7 +1.d0/8.d0*r**6   +13.d0/24.d0*r**5
     &    +79.d0/72.d0*r**4  +65.d0/72.d0*r**3 +7.d0/120.d0*r**2
     &   + 13.d0/72.d0*r     +1447.d0/2520.d0
      ELSE IF ((r.gt. -1.0D0).and.(r.le. 0.0D0)) THEN
        spline_33 =
     &   -11.d0/756.d0*r**7  -1.d0/18.d0*r**6
     &   +7.d0/36.d0*r**4    -29.d0/60.d0*r**2
     &   +691.d0/1260.d0
      ELSE IF ((r.gt. 0.0D0).and.(r.le. 1.0D0)) THEN
        spline_33 =
     &   11.d0/756.d0*r**7  -1.d0/18.d0*r**6
     &   +7.d0/36.d0*r**4   -29.d0/60.d0*r**2
     &   +691.d0/1260.d0
      ELSE IF ((r.gt. 1.0D0).and.(r.le. 2.0D0)) THEN
        spline_33 =
     &    -17.d0/1512.d0*r**7 +1.d0/8.d0*r**6   -13.d0/24.d0*r**5
     &    +79.d0/72.d0*r**4   -65.d0/72.d0*r**3 +7.d0/120.d0*r**2
     &    -13.d0/72.d0*r      +1447.d0/2520.d0
      ELSE IF ((r.gt. 2.0D0).and.(r.le. 3.0D0)) THEN
        spline_33 =
     &    29.d0/7560.d0*r**7 -5.d0/72.d0*r**6 +21.d0/40.d0*r**5
     &   -17.d0/8.d0*r**4    +39.d0/8.d0*r**3 -243.d0/40.d0*r**2
     &   +27.d0/8.d0*r       -81.d0/280.d0
	ELSE IF (r .gt. 3.0D0) THEN
	  spline_33 = 0.D0
      END IF
      RETURN
      End Function
!######################################################################
       Double precision function phi_r1smth(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
       Double precision :: PI,abr
       PI = 4.D0*DATAN(1.D0)
       abr=SQRT(r*r)
      IF (abr.ge.1.5) THEN
        phi_r1smth = 0.0
      ELSE IF ((abr.lt.1.5).and.(abr.ge.0.5)) THEN
        phi_r1smth = 9./8.-3.*abr/2+abr**2/2
      ELSE IF ((abr.lt.0.5).and.(abr.ge.0.0)) THEN
        phi_r1smth = 3./4.-abr**2
      END IF
      RETURN
      End Function
!######################################################################
      Double precision function phi_r2smth(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
       Double precision :: PI
       PI = 4.D0*DATAN(1.D0)
      IF (r.le.-2.5) THEN
        phi_r2smth = 0.0
      ELSE IF ((r.ge.-2.5).and.(r.le.-1.5)) THEN
        phi_r2smth= -1./8./PI*(-5.*PI-2.*PI*r+4.*sin(PI/4.*(-2.*r-1.)))
      ELSE IF ((r.ge.-1.5).and.(r.le.0.0)) THEN
        phi_r2smth = 1./4./PI*(PI+2.*sin(PI/4.*(-2.*r+1.))
     &                           -2.*sin(PI/4.*(-2.*r-1.)))
      ELSE IF ((r.ge.0.0).and.(r.le.1.5)) THEN
        phi_r2smth = 1./4./PI*(PI+2.*sin(PI/4.*(2.*r+1.))
     &                           -2.*sin(PI/4.*(2.*r-1.)))
      ELSE IF ((r.ge.1.5).and.(r.le.2.5)) THEN
        phi_r2smth= -1./8./PI*(-5.*PI+2.*PI*r+4.*sin(PI/4.*(2.*r-1.)))
      ELSE IF (r.ge.2.5) THEN
        phi_r2smth = 0.0
      END IF

      RETURN
      End Function
!######################################################################
       Double precision function phi_r3(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
      IF (r.le.-1.5) THEN
        phi_r3 = 0.0
      ELSE IF ((r.ge.-1.5).and.(r.le.-0.5)) THEN
        phi_r3 = 1.0/6.0*(5.0+3.0*r-sqrt(-3.0*(1.0+r)**2+1.0))
      ELSE IF ((r.ge.-0.5).and.(r.le.0.0)) THEN
        phi_r3 = 1.0/3.0*(1.0+sqrt(-3.0*r**2+1.0))
      ELSE IF ((r.ge.0.0).and.(r.le.0.5)) THEN
        phi_r3 = 1.0/3.0*(1.0+sqrt(-3.0*r**2+1.0))
      ELSE IF ((r.ge.0.5).and.(r.le.1.5)) THEN
        phi_r3 = 1.0/6.0*(5.0-3.0*r-sqrt(-3.0*(1.0-r)**2+1.0))
      ELSE IF (r.ge.1.5) THEN
        phi_r3 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
       Double precision function phi_r3smth2(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
       Double precision :: PI
       PI = 4.D0*DATAN(1.D0)
      IF (r.le.-2.0) THEN
        phi_r3smth2 = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r3smth2 = 55.0/48.0 - sqrt(3.0)*pi/108.0 + 13.0*r/12.0
     &+ r**2/4.0 + (-2.0*r-3.0)/48.0*sqrt(-12.0*r**2-36.0*r-23.0)
     &+ sqrt(3.0)/36.0*ASIN(sqrt(3.0)/2.0*(-2.0*r-3.0))
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r3smth2 = 17.0/48.0 + sqrt(3.0)*pi/108.0 - r/4.0
     &- r**2/4.0 + (2.0*r+1.0)/16.0*sqrt(-12.0*r**2-12.0*r+1.0)
     &- sqrt(3.0)/12.0*ASIN(sqrt(3.0)/2.0*(-2.0*r-1.0))
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN
        phi_r3smth2 = 17.0/48.0 + sqrt(3.0)*pi/108.0 + r/4.0
     &- r**2/4.0 + (-2.0*r+1.0)/16.0*sqrt(-12.0*r**2+12.0*r+1.0)
     &- sqrt(3.0)/12.0*ASIN(sqrt(3.0)/2.0*(2.0*r-1.0))
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r3smth2 = 55.0/48.0 - sqrt(3.0)*pi/108.0 - 13.0*r/12.0
     &+ r**2/4.0 + (2.0*r-3.0)/48.0*sqrt(-12.0*r**2+36.0*r-23.0)
     &+ sqrt(3.0)/36.0*ASIN(sqrt(3.0)/2.0*(2.0*r-3.0))
      ELSE IF (r.ge.2.0) THEN
        phi_r3smth2 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
       Double precision function phi_r3smth(r)
!######################################################################
      implicit none
      Double precision, intent(in) :: r
      Double precision :: scal1,scal2,scal3,scal4,scal5,scal6

      scal1 = 1.095450017660160615261  ! 55.0/48.0 - sqrt(3.0)*pi/108.0
      scal2 = 1.083333333333333333333  ! 13.0/12.0
      scal3 = 0.4045499823398393847387 ! 17.0/48.0 + sqrt(3.0)*pi/108.0
      scal4 = 0.0481125224324688137091 ! sqrt(3.0)/36.0
      scal5 = 0.1443375672974064411273 ! sqrt(3.0)/12.0
      scal6 = 0.8660254037844386467637 ! sqrt(3.0)/2.0

      IF (r.le.-2.d0) THEN
        phi_r3smth = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r3smth = scal1 + scal2*r + scal4*ASIN(scal6*(-2.0*r-3.0))
     &+ 0.25*r**2 + (-2.0*r-3.0)/48.0*sqrt(-12.0*r**2-36.0*r-23.0)
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r3smth = scal3 - r/4.0 - scal5*ASIN(scal6*(-2.0*r-1.0))
     &- 0.25*r**2 + (2.0*r+1.0)/16.0*sqrt(-12.0*r**2-12.0*r+1.0)
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN
        phi_r3smth = scal3 + r/4.0 - scal5*ASIN(scal6*(2.0*r-1.0))
     &- 0.25*r**2 + (-2.0*r+1.0)/16.0*sqrt(-12.0*r**2+12.0*r+1.0)
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r3smth = scal1 - scal2*r + scal4*ASIN(scal6*(2.0*r-3.0))
     &+ 0.25*r**2 + (2.0*r-3.0)/48.0*sqrt(-12.0*r**2+36.0*r-23.0)
      ELSE IF (r.ge.2.0) THEN
        phi_r3smth = 0.0
      END IF

      RETURN
      End Function
!######################################################################
       Double precision function phi_r4(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
      IF (r.le.-2.0) THEN
        phi_r4 = 0.0
      ELSE IF ((r.ge.-2.0).and.(r.le.-1.0)) THEN
        phi_r4 = 1.0/8.0*(5.0+2.0*r-sqrt(-7.0-12.0*r-4.0*r**2))
      ELSE IF ((r.ge.-1.0).and.(r.le.0.0)) THEN
        phi_r4 = 1.0/8.0*(3.0+2.0*r+sqrt(1.0-4.0*r-4.0*r**2))
      ELSE IF ((r.ge.0.0).and.(r.le.1.0)) THEN
        phi_r4 = 1.0/8.0*(3.0-2.0*r+sqrt(1.0+4.0*r-4.0*r**2))
      ELSE IF ((r.ge.1.0).and.(r.le.2.0)) THEN
        phi_r4 = 1.0/8.0*(5.0-2.0*r-sqrt(-7.0+12.0*r-4.0*r**2))
      ELSE IF (r.ge.2.0) THEN
        phi_r4 = 0.0
      END IF

      RETURN
      End Function
!######################################################################
       Double precision function phi_r4smth(r)
!######################################################################
      implicit none
       Double precision, intent(in) :: r
       Double precision :: PI,ar
       PI = 4.D0*DATAN(1.D0)
	ar=abs(r)
      IF ((ar.ge.0.0).and.(ar.le.0.5)) THEN
	phi_r4smth = 3.0/8.0+ PI/32.0 - r*r/4.0
      ELSE IF ((ar.ge.0.5).and.(ar.le.1.5)) THEN
	phi_r4smth = 1.0/4.0 + (1.0-ar)/8.0*SQRT(-2.0+8.0*ar -4.0*r*r)
     & -1.0/8.0*ASIN(sqrt(2.0)*(ar-1.0))
      ELSE IF ((ar.ge.1.5).and.(ar.le.2.5)) THEN
	phi_r4smth = 17.0/16.0 - PI/64.0 - 3.0*ar/4.0+ r*r/8.0
     & + (ar-2.0)/16.0 * SQRT(-14.0+ 16.0*ar - 4.0*r*r)
     & + 1.0/16.0*ASIN(sqrt(2.0)*(ar-2.0))
      ELSE IF (ar.ge.2.5) THEN
        phi_r4smth = 0.0
      END IF
      RETURN
      End Function
!######################################################################
       Double precision function dh(dx,dy,dz,xij,yij,zij,Xl,Yl,Zl,order)
!######################################################################
      implicit none
       Double precision,    intent(in) :: dx,dy,dz,xij,yij,zij,Xl,Yl,Zl
       INTEGER, intent(in) :: order
       Double precision :: phi_r2smth,phi_r3smth,phi_r4
       Double precision :: phi_r3,phi_r1smth,phi_r4smth,spline_33

      SELECT CASE (order)

         CASE (1)
      dh =  phi_r1smth((xij-Xl)/dx)
     & * phi_r1smth((yij-Yl)/dy) * phi_r1smth((zij-Zl)/dz)
         CASE (2)
      dh =   phi_r2smth((xij-Xl)/dx)
     & * phi_r2smth((yij-Yl)/dy) * phi_r2smth((zij-Zl)/dz)
         CASE (3)
       dh =   phi_r3smth((xij-Xl)/dx)
     &   * phi_r3smth((yij-Yl)/dy) * phi_r3smth((zij-Zl)/dz)
         CASE (4)
       dh =   phi_r4smth((xij-Xl)/dx)
     &   * phi_r4smth((yij-Yl)/dy) * phi_r4smth((zij-Zl)/dz)
         CASE (5)
       dh =   phi_r3((xij-Xl)/dx)
     &   * phi_r3((yij-Yl)/dy) * phi_r3((zij-Zl)/dz)
         CASE (6)
      dh =   phi_r4((xij-Xl)/dx)
     &   * phi_r4((yij-Yl)/dy) * phi_r4((zij-Zl)/dz)
         CASE (7)
      dh =   spline_33((xij-Xl)/dx)
     &   * spline_33((yij-Yl)/dy) * spline_33((zij-Zl)/dz)
      Case default

         print*, '===ERROR==='
         print*, ' order of delta function is not selected '
          STOP

      End Select

      RETURN
      End Function
!######################################################################
!######################################################################
!		MOVING LEAST-SQUARE methodology
! Implemented by Pablo (2015)
! Algorithm from Ramirez and Nogueira (University of A Coruna)
!######################################################################
!######################################################################
	subroutine ShapeFunction_MLS(UorV,L,ib)
!######################################################################
         use vars
	 use multidata
         use mpi
	 use imb
         implicit none
         INTEGER :: order_mls,nbase,MAXCELL,MAXNEIG
	 LOGICAL :: vanella_mls
         INTEGER, intent(in) :: UorV,L,ib
         INTEGER :: I,J,K,ipface,inodehalo,nn,neignum
         INTEGER:: MVefx(126),MVefy(126),MVefz(126)
         Double precision :: vmaxdist,xN,yN,zN,h0,xv2,yv2,zv2
    	 Double precision::  Xf(126),Yf(126),Zf(126),hx,hy,hz
         Double precision :: offsety,offsetx,offsetz,ratioHKx1,ratioHKx2
         Double precision :: ratioHKy1,ratioHKy2,ratioHKz1,ratioHKz2
         Double precision :: kwx1,kwx2,kwy1,kwy2,kwz1,kwz2,dist_ff
	 Double precision :: parametros(9),W(126),difx(126)
	 Double precision :: dify(126),difz(126)
         Double precision :: dX2(126),dY2(126),dZ2(126)
         Double precision :: FF(126),dFFX(126),dFFY(126),dFFZ(126)
         Double precision :: ddFFXX(126),ddFFXY(126),ddFFYY(126)
         Double precision :: ddFFXZ(126),ddFFZZ(126),ddFFYZ(126)
	 Double precision :: nmls,k_mls
         INTEGER :: MLS_neignum(maxnodeIBS)

!"""  Data for MLS

	MAXCELL=10000 ; MAXNEIG=65
	MLS_neignum=MAXNEIG
	order_mls=1
	k_mls=5.0d+00

        if (order_mls .eq. 1) nbase=4
        if (order_mls .eq. 2) nbase=10
        if (order_mls .eq. 3) nbase=20
!""""

	Do i=1,MAXNEIG
 	  MVefx(i)=0 ; MVefy(i)=0 ; MVefz(i)=0
	Enddo
	nn=0  ; nxl=1.9999999

	IF (UorV.eq.1) then
       DO I = 1, dom(ib)%ttc_i
       IF ( dom(ib)%x(i).gt.(nodex_loc(L)+nxl*dom(ib)%dx) .or.
     &      dom(ib)%x(i).lt.(nodex_loc(L)-nxl*dom(ib)%dx))  GOTO 100
        DO J = 1, dom(ib)%ttc_j
       IF (dom(ib)%yc(j).gt.(nodey_loc(L)+nxl*dom(ib)%dy) .or.
     &     dom(ib)%yc(j).lt.(nodey_loc(L)-nxl*dom(ib)%dy))  GOTO 101
          DO K = 1, dom(ib)%ttc_k
       IF (dom(ib)%zc(k).gt.(nodez_loc(L)+nxl*dom(ib)%dz) .or.
     &     dom(ib)%zc(k).lt.(nodez_loc(L)-nxl*dom(ib)%dz) )  GOTO 102
		nn=nn+1
	IF (nn.gt.MAXNEIG) write(6,*)'More Neighbours than MAXNEIG!',nn
	    MVefx(nn)=I   ;  MVefy(nn)=J	;  MVefz(nn)=K
           Xf(nn)=dom(ib)%x(i)  ; Yf(nn)=dom(ib)%yc(j)
	    Zf(nn)=dom(ib)%zc(k)
102 	CONTINUE
         END DO
101 	CONTINUE
        END DO
100 	CONTINUE
       END DO
	ENDIF
	IF (UorV.eq.2) then
       DO I = 1, dom(ib)%ttc_i
       IF ( dom(ib)%xc(i).gt.(nodex_loc(L)+nxl*dom(ib)%dx) .or.
     &      dom(ib)%xc(i).lt.(nodex_loc(L)-nxl*dom(ib)%dx) )  GOTO 200
        DO J = 1, dom(ib)%ttc_j
       IF (dom(ib)%y(j) .gt.(nodey_loc(L)+nxl*dom(ib)%dy) .or.
     &     dom(ib)%y(j) .lt.(nodey_loc(L)-nxl*dom(ib)%dy) )  GOTO 201
          DO K = 1, dom(ib)%ttc_k
	IF( dom(ib)%zc(k).gt.(nodez_loc(L)+nxl*dom(ib)%dz) .or.
     &     dom(ib)%zc(k).lt.(nodez_loc(L)-nxl*dom(ib)%dz) )  GOTO 202
		nn=nn+1
	IF (nn.gt.MAXNEIG)
     &       write(6,*)'More Neighbours than MAXNEIG!',nn,nxl
		MVefx(nn)=I   ;  MVefy(nn)=J	;  MVefz(nn)=K
              Xf(nn)=dom(ib)%xc(i)
	       Yf(nn)=dom(ib)%y(j)
	       Zf(nn)=dom(ib)%zc(k)
202 	CONTINUE
         END DO
201 	CONTINUE
        END DO
200 	CONTINUE
       END DO
	ENDIF
	IF (UorV.eq.3) then
       DO I = 1, dom(ib)%ttc_i
       IF ( dom(ib)%xc(i).gt.(nodex_loc(L)+nxl*dom(ib)%dx) .or.
     &      dom(ib)%xc(i).lt.(nodex_loc(L)-nxl*dom(ib)%dx)) GOTO 300
        DO J = 1, dom(ib)%ttc_j
       IF ( dom(ib)%yc(j).gt.(nodey_loc(L)+nxl*dom(ib)%dy) .or.
     &      dom(ib)%yc(j).lt.(nodey_loc(L)-nxl*dom(ib)%dy)) GOTO 301
          DO K = 1, dom(ib)%ttc_k
       IF ( dom(ib)%z(k) .gt.(nodez_loc(L)+nxl*dom(ib)%dz) .or.
     &      dom(ib)%z(k) .lt.(nodez_loc(L)-nxl*dom(ib)%dz) ) GOTO 302
		nn=nn+1
	IF (nn.gt.MAXNEIG)
     &       write(6,*)'More Neighbours than MAXNEIG!',nn,nxl
		MVefx(nn)=I   ;  MVefy(nn)=J	;  MVefz(nn)=K
              Xf(nn)=dom(ib)%xc(i)
	       Yf(nn)=dom(ib)%yc(j)
	       Zf(nn)=dom(ib)%z(k)
302 	CONTINUE
         END DO
301 	CONTINUE
        END DO
300 	CONTINUE
       END DO
	ENDIF

	neignum=nn
	MLS_neignum(L)=neignum
!--------------------------------------------------------
        vmaxdist= 0.d+00
    	 do j=1, neignum
	  difx(j)= 0.d+0 ;    dify(j)= 0.d+0;    difz(j)= 0.d+00
	 enddo

    	  do j=1, neignum
	 dist_ff=DSQRT((nodex_loc(L)-Xf(j))**2+(nodey_loc(L)-Yf(j))**2
     &		+(nodez_loc(L)-Zf(j))**2)
	    if(dist_ff.gt.vmaxdist) vmaxdist= dist_ff
	     	difx(j)=Xf(j)-nodex_loc(L)
		dify(j)=Yf(j)-nodey_loc(L)
		difz(j)=Zf(j)-nodez_loc(L)
	  enddo

	h0=1.0d+00
	hx= h0*maxval(DABS(difx(1:neignum)))
	hy= h0*maxval(DABS(dify(1:neignum)))
	hz= h0*maxval(DABS(difz(1:neignum)))

	parametros(1)= k_mls
	parametros(2)= k_mls
	parametros(3)= k_mls
	parametros(4)= k_mls
	parametros(5)= k_mls
	parametros(6)= k_mls
	parametros(7)= 0.0d+00
	parametros(8)= 0.0d+00
	parametros(9)= 0.0d+00

	ratioHKx1= parametros(1)
	ratioHKx2= parametros(2)
	ratioHKy1= parametros(3)
	ratioHKy2= parametros(4)
	ratioHKz1= parametros(5)
	ratioHKz2= parametros(6)
	offsetx  = parametros(7)
	offsety  = parametros(8)
	offsetz  = parametros(9)

	h0= 1.0d+00
	kwx1= h0*ratioHKx1
	kwx2= h0*ratioHKx2
	kwy1= h0*ratioHKy1
	kwy2= h0*ratioHKy2
	kwz1= h0*ratioHKz1
	kwz2= h0*ratioHKz2

	call  kerneltododer(W,dX2,dY2,dZ2,difx,dify,difz,hx,hy,hz,
     &  neignum,kwx1,kwx2,kwy1,kwy2,kwz1,kwz2,MAXNEIG)

        call forma3Dder(FF,W,dX2,dY2,dZ2,neignum,Xf,Yf,Zf
     & ,nodex_loc(L),nodey_loc(L),nodez_loc(L),hx,hy,hz,
     & dFFX,dFFY,dFFZ,ddFFXX,ddFFXY,ddFFXZ,ddFFYY,ddFFYZ,ddFFZZ,
     &  MAXNEIG,nbase)

	  do j=1, MLS_neignum(L)
	   IF (UorV.eq.1) then
	   	dh1_loc(L,j)=FF(j)  	;I_nr_U(L,j)=MVefx(j)
	    	J_nr_U(L,j)=MVefy(j)	;K_nr_U(L,j)=MVefz(j)
	   ELSEIF(UorV.eq.2) then
	    	dh2_loc(L,j)=FF(j)	;I_nr_V(L,j)=MVefx(j)
		J_nr_V(L,j)=MVefy(j)	;K_nr_V(L,j)=MVefz(j)
	   ELSEIF(UorV.eq.3) then
	   	dh3_loc(L,j)=FF(j)	;I_nr_W(L,j)=MVefx(j)
		J_nr_W(L,j)=MVefy(j)	;K_nr_W(L,j)=MVefz(j)
	   ENDIF
          enddo

	  IF(UorV.eq.1) KmaxU(L)=MLS_neignum(L)
	  IF(UorV.eq.2) KmaxV(L)=MLS_neignum(L)
	  IF(UorV.eq.3) KmaxW(L)=MLS_neignum(L)

	return
	end
!######################################################################
      subroutine kerneltododer(W,dX1,dY1,dZ1,difx,dify,difz,hx,hy,hz,
     &  neignum,kwx1,kwx2,kwy1,kwy2,kwz1,kwz2,MAXNEIG)
!######################################################################
        use mpi
	implicit none
        INTEGER, intent(in):: neignum,MAXNEIG
	Double precision, intent(in) :: hx,hy,hz,kwx1,kwx2,kwy1
	Double precision, intent(in) :: kwy2,kwz1,kwz2
	Double precision, intent(in) :: difx(MAXNEIG)
	Double precision, intent(in) ::dify(MAXNEIG)
	Double precision, intent(in) :: difz(MAXNEIG)
        INTEGER :: I,J
        Double precision:: cero, coef,cx1,cx2,cy1,cy2,cz1,cz2,PI
        Double precision:: dmx,dmy,dmz,Wx,Wy,Wz,dWx,dWy,dWz
        Double precision:: coef1x,coef2x,coefd1x,coefd2x,coefd3x
        Double precision:: coef1y,coef2y,coefd1y,coefd2y,coefd3y
        Double precision:: coef1z,coef2z,coefd1z,coefd2z,coefd3z
	Double precision:: sx(MAXNEIG),sy(MAXNEIG),sz(MAXNEIG)
	Double precision:: W(MAXNEIG),dX1(MAXNEIG),dY1(MAXNEIG),dZ1(MAXNEIG)

        cero=1.d-08  ;   coef=1.d+00  ;    PI = 4.D0*DATAN(1.D0)

        do j=1, neignum
	  sx(j)=0.0d+00   ;  sy(j)=0.0d+00;  sz(j)=0.0d+00
	enddo

! Primero cogemos las distancias que nos interesan
      do j=1, neignum
	sx(j)=dabs(difx(j)) ; sy(j)=dabs(dify(j)); sz(j)=dabs(difz(j))
	dmx=2.0d+00*hx 	; dmy=2.0d+00*hy 	;  dmz=2.0d+00*hz
	cx1= dmx/kwx1  	;  cx2= dmx/kwx2
	cy1= dmy/kwy1	;  cy2= dmy/kwy2
	cz1= dmz/kwz1	;  cz2= dmz/kwz2

	if (difx(j).ge.0.0d+00)then
	  coef1x= exp(-(sx(j)/cx1)**2) - exp(-(dmx/cx1)**2)
	  coef2x= 1.0d+00 - exp(-(dmx/cx1)**2)
	  coefd1x=exp(-(sx(j)/cx1)**2)
	  coefd2x=coef2x
	  coefd3x=-2.0d+00*sx(j)/(cx1*cx1)
	else
	  coef1x= exp(-(sx(j)/cx2)**2) - exp(-(dmx/cx2)**2)
	  coef2x= 1.0d+00 - exp(-(dmx/cx2)**2)
	  coefd1x=exp(-(sx(j)/cx2)**2)
	  coefd2x=coef2x
	  coefd3x=-2.0d+00*sx(j)/(cx2*cx2)
	endif
	if (dify(j).ge.0.0d+00)then
	  coef1y= exp(-(sy(j)/cy1)**2) - exp(-(dmy/cy1)**2)
	  coef2y= 1.0d+00 - exp(-(dmy/cy1)**2)
	  coefd1y=exp(-(sy(j)/cy1)**2)
	  coefd2y=coef2y
	  coefd3y=-2.0d+00*sy(j)/(cy1*cy1)
	else
	  coef1y= exp(-(sy(j)/cy2)**2) - exp(-(dmy/cy2)**2)
	  coef2y= 1.0d+00 - exp(-(dmy/cy2)**2)
	  coefd1y=exp(-(sy(j)/cy2)**2)
	  coefd2y=coef2y
	  coefd3y=-2.0d+00*sy(j)/(cy2*cy2)
	endif
	if (difz(j).ge.0.0d+00)then
	  coef1z= exp(-(sz(j)/cz1)**2) - exp(-(dmz/cz1)**2)
	  coef2z= 1.0d+00 - exp(-(dmz/cz1)**2)
	  coefd1z=exp(-(sz(j)/cz1)**2)
	  coefd2z=coef2z
	  coefd3z=-2.0d+00*sz(j)/(cz1*cz1)
	else
	  coef1z= exp(-(sz(j)/cz2)**2) - exp(-(dmz/cz2)**2)
	  coef2z= 1.0d+00 - exp(-(dmz/cz2)**2)
	  coefd1z=exp(-(sz(j)/cz2)**2)
	  coefd2z=coef2z
	  coefd3z=-2.0d+00*sz(j)/(cz2*cz2)
	endif

	Wx= coef1x/coef2x ; Wy= coef1y/coef2y ;	Wz= coef1z/coef2z

	dWx= coefd3x*coefd1x/coefd2x
	dWy= coefd3y*coefd1y/coefd2y
	dWz= coefd3z*coefd1z/coefd2z

	W(j)= Wx*Wy*Wz

	if(sx(j).gt.cero)then
	  dX1(j)= Wy*Wz*dWx*(difx(j)/sx(j))
	 else
	  dX1(j)= Wz*Wy*dWx*(difx(j))
	endif
	if(sy(j).gt.cero)then
	  dY1(j)= Wx*Wz*dWy*(dify(j)/sy(j))
	 else
	  dY1(j)= Wx*Wz*dWy*(dify(j))
	endif
	if(sz(j).gt.cero)then
	  dZ1(j)= Wx*Wy*dWz*(difz(j)/sz(j))
	 else
	  dZ1(j)= Wx*Wy*dWz*(difz(j))
	endif
      enddo !j-loop

	return
	end
!######################################################################
      subroutine forma3Dder(FF,W2,dX2,dY2,dZ2,neignum,Xmls,Ymls,Zmls
     &  ,xgau,ygau,zgau,hx,hy,hz,
     &   dFFX,dFFY,dFFZ,ddFFXX,ddFFXY,ddFFXZ,ddFFYY,ddFFYZ,ddFFZZ,
     &   MAXNEIG,nbase)
!######################################################################
        implicit none
        INTEGER, intent(in) :: neignum,MAXNEIG,nbase
        Double precision, intent(in) :: hx,hy,hz,xgau,ygau,zgau
        Double precision, intent(in) :: W2(MAXNEIG)
	Double precision, intent(in) :: Xmls(MAXNEIG),Ymls(MAXNEIG)
	Double precision, intent(in) :: Zmls(MAXNEIG)
	Double precision, intent(in) :: dX2(MAXNEIG),dY2(MAXNEIG)
	Double precision, intent(in) :: dZ2(MAXNEIG)
        INTEGER :: I,J,K,ifila,icolumna,ibase,nelim,icol
        Double precision :: xg,yg,zg,wmax,wmin,valor
        Double precision :: FF(MAXNEIG),dFFX(MAXNEIG),dFFY(MAXNEIG)
        Double precision :: dFFZ(MAXNEIG)
        Double precision :: ddFFXX(MAXNEIG),ddFFXY(MAXNEIG)
        Double precision :: ddFFYY(MAXNEIG)
        Double precision :: ddFFXZ(MAXNEIG),ddFFYZ(MAXNEIG)
        Double precision :: ddFFZZ(MAXNEIG)
	Double precision :: A(nbase,nbase),vIA(nbase,nbase)
        Double precision :: eye(nbase,nbase)
        Double precision :: C(nbase,MAXNEIG),PtC(MAXNEIG,MAXNEIG)
        Double precision :: auxiliar(MAXNEIG,nbase)
	Double precision :: auxiliar1(nbase),auxiliar2(nbase)
        Double precision :: sol(nbase,nbase),wsv(10),vsv(10,10),coef

c Inicializamos la matriz C
        do i=1,nbase
	 do j=1, MAXNEIG
	  C(i,j)=0.d+00
	 enddo
	enddo
c Construimos la matriz A

      do i=1,nbase
	do j=1,nbase
	 A(i,j)= 0.d+00
	 vIA(i,j)=0.d+00
	 if(i.eq.j)then
	  eye(i,j)= 1.d+00
	 else
	  eye(i,j)= 0.d+00
	 endif
	enddo
      enddo

c Construimos un vector auxiliar para hacer los calculos
      do k=1,neignum
       xg=(Xmls(k)-xgau)/hx ; yg=(Ymls(k)-ygau)/hy ;zg=(Zmls(k)-zgau)/hz

      if(nbase.eq.4) then
      	auxiliar(k, 1)= 1.d+00
	auxiliar(k, 2)= xg
	auxiliar(k, 3)= yg
	auxiliar(k, 4)= zg
      elseif(nbase.eq.10) then
	auxiliar(k, 1)= 1.d+00
	auxiliar(k, 2)= xg
	auxiliar(k, 3)= yg
	auxiliar(k, 4)= zg
	auxiliar(k, 5)= xg*xg
	auxiliar(k, 6)= xg*yg
	auxiliar(k, 7)= xg*zg
	auxiliar(k, 8)= yg*yg
	auxiliar(k, 9)= yg*zg
	auxiliar(k,10)= zg*zg
      elseif(nbase.eq.20) then
	auxiliar(k, 1)= 1.d+00
	auxiliar(k, 2)= xg
	auxiliar(k, 3)= yg
	auxiliar(k, 4)= zg
	auxiliar(k, 5)= xg*xg
	auxiliar(k, 6)= xg*yg
	auxiliar(k, 7)= xg*zg
	auxiliar(k, 8)= yg*yg
	auxiliar(k, 9)= yg*zg
	auxiliar(k,10)= zg*zg
	auxiliar(k,11)= xg*xg*xg
	auxiliar(k,12)= xg*xg*yg
	auxiliar(k,13)= xg*xg*zg
	auxiliar(k,14)= xg*yg*zg
	auxiliar(k,15)= yg*yg*yg
	auxiliar(k,16)= yg*yg*xg
	auxiliar(k,17)= yg*yg*zg
	auxiliar(k,18)= zg*zg*zg
	auxiliar(k,19)= zg*zg*xg
	auxiliar(k,20)= zg*zg*yg
       endif

       do ifila= 1,nbase
	do icolumna= 1,nbase
     	 A(ifila,icolumna)= A(ifila,icolumna)+
     &         W2(k)*auxiliar(k,ifila)*auxiliar(k,icolumna)
	enddo
       enddo
      enddo

c Calculamos la inversa de A
c Para calcularla resolvemos 6 sistemas de ecuaciones
c Primero triangularizamos la matriz A y hacemos las operaciones por filas
c sobre la matriz identidad
      do i=1,nbase-1
c Comprobamos que el pivote no sea nulo
        if(A(i,i).lt.1.d-06)then
	  write(6,*)' Pivote nulo',hx,hy,hz,i
	  pause
	endif
       do j=i+1,nbase
        coef=-A(j,i)/A(i,i)
          do k=i,nbase
            A(j,k)=A(j,k)+coef*A(i,k)
          enddo
c Aplicamos la operación a las columnas de la identidad
	    do icol=1,nbase
            eye(j,icol)= eye(j,icol)+coef*eye(i,icol)
	    enddo
        enddo
      enddo
      do icol=1,nbase
	do i=1,nbase
	 auxiliar1(i)= eye(i,icol)
	enddo
         call Back_Substitution(nbase,A,auxiliar1,auxiliar2)
	do i=1,nbase
	 vIA(i,icol)= auxiliar2(i)
	enddo
       enddo

c We calculate C, which is A^-1*B
      do i=1,nbase
	do k=1, neignum
 	 C(i,k)= 0.d+00
	  do j=1,nbase
	  C(i,k)= C(i,k) + vIA(i,j)*auxiliar(k,j)
	  enddo
	 C(i,k)= C(i,k)*W2(k)
	enddo
      enddo
c We calculate I-Pt*C
      do i=1,neignum
	do j=1,neignum

	valor= 0.d+00
	do ibase=1,nbase
		valor= valor + C(ibase,j)*auxiliar(i,ibase)
	enddo

		PtC(i,j)=-valor
		if(i.eq.j)PtC(i,j)=PtC(i,j)+1.d+00
	  enddo
	enddo

      if(nbase.eq.4) then
        do k=1,neignum
	   FF(k)= C(1,k)
	enddo
        do j=1,neignum
	 dFFX(j)=C(2,j)/hx
	 dFFY(j)=C(3,j)/hy
	 dFFZ(j)=C(4,j)/hz
	 do k=1,neignum
           dFFX(j)=dFFX(j)+dX2(k)*C(1,k)*PtC(k,j)/W2(k)
           dFFY(j)=dFFY(j)+dY2(k)*C(1,k)*PtC(k,j)/W2(k)
           dFFZ(j)=dFFZ(j)+dZ2(k)*C(1,k)*PtC(k,j)/W2(k)
	 enddo
	enddo
      elseif(nbase.eq.10) then
        do k=1,neignum
 	  FF(k)= C(1,k)
	enddo
        do j=1,neignum
	  dFFX(j)=C(2,j)/hx
	  dFFY(j)=C(3,j)/hy
	 dFFZ(j)=C(4,j)/hz
            do k=1,neignum
             dFFX(j)=dFFX(j)+dX2(k)*C(1,k)*PtC(k,j)/W2(k)
             dFFY(j)=dFFY(j)+dY2(k)*C(1,k)*PtC(k,j)/W2(k)
             dFFZ(j)=dFFZ(j)+dZ2(k)*C(1,k)*PtC(k,j)/W2(k)
            enddo
	enddo
        do j=1,neignum
	  ddFFXY(j)=        C(5,j)/(hx*hy)
	  ddFFXZ(j)=        C(6,j)/(hx*hz)
	  ddFFYZ(j)=        C(7,j)/(hy*hz)
	  ddFFXX(j)= 2.d+00*C(8,j)/(hx*hx)
	  ddFFYY(j)= 2.d+00*C(9,j)/(hy*hy)
	  ddFFZZ(j)=2.d+00*C(10,j)/(hz*hz)
        enddo
      elseif(nbase.eq.20) then
        do k=1,neignum
	  FF  (k)= C(1,k)
	enddo
        do j=1,neignum
	  dFFX(j)=C(2,j)/hx
	  dFFY(j)=C(3,j)/hy
	  dFFZ(j)=C(4,j)/hZ
	 do k=1,neignum
           dFFX(j)=dFFX(j)+dX2(k)*C(1,k)*PtC(k,j)/W2(k)
           dFFY(j)=dFFY(j)+dY2(k)*C(1,k)*PtC(k,j)/W2(k)
           dFFZ(j)=dFFZ(j)+dZ2(k)*C(1,k)*PtC(k,j)/W2(k)
	 enddo
	enddo
         do j=1,neignum
	  ddFFXX(j)= 2.d+00*C( 5,j)/(hx*hx)
	  ddFFXY(j)=        C( 6,j)/(hx*hy)
	  ddFFXZ(j)=        C( 7,j)/(hx*hz)
	  ddFFYY(j)= 2.d+00*C( 8,j)/(hy*hy)
	  ddFFYZ(j)=        C( 9,j)/(hy*hz)
	  ddFFZZ(j)= 2.d+00*C(10,j)/(hz*hz)
         enddo
	endif

	return
	end
!######################################################################
	subroutine Back_Substitution(ndim,A,b,x)
!######################################################################
	INTEGER :: i
        INTEGER, intent(in) :: ndim
        Double precision :: A(ndim,ndim),b(ndim),x(ndim)

      x(ndim)=b(ndim)/A(ndim,ndim)
      do i=ndim-1,1,-1
        suma=0
          do j=i+1,ndim
            suma=suma+A(i,j)*x(j)
          enddo
        x(i)=(b(i)-suma)/A(i,i)
      enddo
	return
	end


!======================================================================
      Function quadr(i, j, k)
!======================================================================
!
!       <P_i| r^k |P_j> with inclusion of rel.shift if rel = .true.
!
!----------------------------------------------------------------------

         USE spline_param
         USE hf_atomic_state
         USE hf_orbitals
         USE spline_galerkin

         IMPLICIT NONE

         INTEGER, INTENT(in) :: i, j, k
         REAL(KIND=8) :: quadr
         REAL(KIND=8), EXTERNAL :: BVMV

         REAL(KIND=8), DIMENSION(ns, ks) :: array

         ! get the banded array

         if (k == 0) then
            array = sb
         else if (k == 1) then
            array = r1
         else if (k == -1) then
            array = rm1
         else if (k == -2) then
            array = rm2
         else
            Call mrm(k, array)
         end if

         ! type of symmetry is symmetric
         quadr = BVMV(ns, ks, array, 's', p(1, i), p(1, j))

      END FUNCTION quadr