module gslib

    implicit none

    real, parameter, private :: EPSLON=1.0e-20, UNEST=-1.0, PI=3.14159265,PMX=999., DEG2RAD=3.141592654/180.0

    ! constants for random generator lcg
    integer, parameter :: i64 = selected_int_kind(18)
    integer(i64), parameter :: m_lcg = 2147483648_i64
    integer, parameter :: a_lcg = 1103515245
    integer, parameter :: c_lcg = 12345

    contains

        ! TODO: write a set of validations/tests in two stages
        !       a) sequential tests
        !       b) parallel tests with OpenMP (and coarrays if possible)

        ! NOTE: use LAPACK as replacement for ksol.f90 and ktsol.f90
        !       to compile
        !        a) install openblas precompiled. with conda use
        !           > conda install -c conda-forge openblas
        !        b) just link the library. here an example
        !           > gfortran -o .\test.exe .\test.f90 -L "OpenBLAS-0.3.15" "C:\Users\AMartinez\Miniconda3\pkgs\openblas-0.3.15-pthreads_h543f93c_0\Library\lib\openblas.lib"

        pure integer(i64) function lcg(x)
            !-----------------------------------------------------------------------
            !                 Linear congruential generator
            !              ******************************************
            ! Implements a thread safe linear congruential random generator
            ! that uses glib (GCC) parameters:
            !   mlcgrand        modulus 2^31, or 2147483648
            !   a               multiplier 1103515245
            !   c               increment 12345
            ! as defined in https://en.wikipedia.org/wiki/Linear_congruential_generator#Parameters_in_common_use
            !
            ! To generate a sequence of random numbers:
            !   a) select an initial state (x[0] = seed)
            !   b) run lcgrand(x[0]) to get x[1]
            !   c) to get the next random number pass the current state x[n-1], in other words
            !       x[n] = lcgrand(x[n-1])
            ! please note that here [] denote array, not coarray
            !
            ! the output is a sequence of integers in the inteval ]0, m[
            ! to get uniform numbers divide by the modulus, for example x/2^31, or use function ulcg()
            ! Note that you have to keep a copy of the previous state x[n-1],
            !
            ! see also: https://rosettacode.org/wiki/Linear_congruential_generator#Fortran
            !
            ! INPUT VARIABLES:
            !   x                integer of 64 bits (i64) with the state of the previous
            !                    random number in the sequence
            ! OUTPUT
            !   x[n+1]           integer of 64 bits (i64) with the state of the next
            !                    random number in the sequence
            !-----------------------------------------------------------------------

            ! inputs
            integer(i64), intent(in) :: x

            ! interbal variables defined globally

            lcg = mod(a_lcg * x + c_lcg, m_lcg)

        end function lcg

        pure elemental real function ulcg(x)
            !-----------------------------------------------------------------------
            !                 Real uniform from linear congruential generator
            !              ******************************************
            ! Transform sequence of integers generated by the function lcg into uniform distribution
            !
            ! INPUT VARIABLES:
            !   x                64 bit integers generated by function lcg
            !
            ! OUTPUT
            !   real             with uniform distribution in interval ]0,1[
            !-----------------------------------------------------------------------

            ! inputs
            integer(i64), intent(in) :: x

            ulcg = real(x)/real(m_lcg)

        end function ulcg

        recursive pure subroutine QSort(na,A,I, randi)
            !-----------------------------------------------------------------------
            !                 Sort inplase an array and its index
            !              ******************************************
            ! Sorts an array using a recursive implementation of the quick sort
            ! algorithm.
            ! This is modified from https://rosettacode.org/wiki/Sorting_algorithms/Quicksort#Fortran
            !
            ! INPUT VARIABLES:
            !   nd               Number of data (no missing values)
            !
            ! INPUT/OUTPUT VARIABLES:
            !   A                Real. Array of values to sort in place
            !   I                Integer. Index to track the original order
            !-----------------------------------------------------------------------

            ! inputs
            integer, intent(in) :: na
            real, dimension(na), intent(inout) :: A    ! array value
            integer, dimension(na), intent(inout) :: I ! array index 1,2,3,4...
            integer(i64), intent(inout), optional :: randi       !randon integer at previous state

            ! local
            integer :: left, right, temp_order
            real :: random
            real :: pivot, temp_value
            integer :: marker

            if (.NOT. present(randi)) randi = 736576564

            ! initialize random

            if (na > 1) then
                randi = lcg(randi)
                random = ulcg(randi)                  ! is this OK in parallel? It is preventing to make this subrotine pure
                                                      ! possible solution, use the classical 1/2 na partition

                pivot = A(int(random*real(na-1))+1)   ! Choice a random pivot (not best performance, but avoids worst-case)
                left = 1
                right = na
                ! Partition loop
                do
                    if (left >= right) exit
                    do
                        if (A(right) <= pivot) exit
                        right = right - 1
                    end do
                    do
                        if (A(left) >= pivot) exit
                        left = left + 1
                    end do
                    if (left < right) then
                        temp_value = A(left)
                        temp_order = I(left)
                        A(left) = A(right)
                        I(left) = I(right)
                        A(right) = temp_value
                        I(right) = temp_order
                    end if
                end do

                if (left == right) then
                    marker = left + 1
                else
                    marker = left
                end if

                call QSort(marker-1,    A(:marker-1),I(:marker-1), randi)
                call QSort(nA-marker+1, A(marker:),  I(marker:)  , randi)

            end if

        end subroutine QSort

        pure subroutine nscore(nd,vr,wt,vrg,ierror)
            !-----------------------------------------------------------------------
            !              Transform Univariate Data to Normal Scores
            !              ******************************************
            ! This subroutibe takes "nd" data "vr(i),i=1,...,nd" possibly weighted
            ! by "wt(i),i=,...,nd" and returns the normal scores transform N(0,1)
            ! as "vrg(i),i=1,...,nd".  The extra storage array "tmp" is required
            ! so that the data can be returned in the same order (just in case
            ! there are associated arrays like the coordinate location).
            !
            ! INPUT VARIABLES:
            !   nd               Number of data (no missing values)
            !   vr(nd)           Data values to be transformed
            !   wt(nd)           Weight for each data (don't have to sum to 1.0)
            !                    this is an optional variable, if present will use it,
            !                    otherwise will use equal weighted
            !
            ! OUTPUT VARIABLES:
            !   vrg(nd)          normal scores
            !   ierror           error flag (0=error free,1=problem)
            !
            ! EXTERNAL REFERENCES:

            !   gauinv           Calculates the inverse of a Gaussian cdf
            !   Qsort            sorts a number of arrays in ascending order
            !-----------------------------------------------------------------------

            ! inputs
            integer, intent(in) :: nd
            real, intent(in), dimension(nd) :: vr
            real, intent(in), dimension(nd), optional :: wt

            !output
            real, intent(out), dimension(nd) :: vrg
            integer, intent(out) :: ierror

            ! internal variables
            real, dimension(nd) :: wtt, vra
            integer, dimension(nd) :: ind
            real   :: twt, oldcp, cp
            integer :: i

            ! Sort the data in ascending order and calculate total weight:

            ierror = 0
            twt    = 0.0
            do i=1,nd
                ! initialize internal copy of the variable, weight and index
                ind(i) = i
                vra(i) = vr(i)
                wtt(i) = wt(i)
                if(present(wt)) then
                    twt = twt + 1.
                else
                    twt = twt + wt(i)  ! total weight
                end if
            end do
            if(nd < 1 .OR. twt < EPSLON) then
                ierror = 1
                return
            end if

            call QSort(nd, A=vra, I=ind)

            ! Compute the cumulative probabilities:

            oldcp = 0.0
            cp    = 0.0
            do i=1,nd
                cp     =  cp + wtt(ind(i)) / twt
                wtt(i)  = (cp + oldcp)/ 2.0
                oldcp  =  cp
                call gauinv(dble(wtt(ind(i))),vrg(ind(i)),ierror)
                if (ierror>0) return
            end do

        end subroutine nscore

        pure subroutine gauinv(p,xp,ierror)
            !-----------------------------------------------------------------------
            ! Computes the inverse of the standard normal cumulative distribution
            ! function with a numerical approximation from : Statistical Computing,
            ! by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.
            !
            ! INPUT/OUTPUT:
            !   p    = double precision cumulative probability value: dble(psingle)
            !   xp   = G^-1 (p) in single precision
            !   ierr = 1 - then error situation (p out of range), 0 - OK
            !-----------------------------------------------------------------------
            ! inputs
            real*8, intent (in) :: p

            ! output
            real, intent (out) :: xp
            integer, intent (out) :: ierror

            ! internal variables
            real*8 :: y,pp
            real*8, parameter ::  lim=1.0e-10
            real*8, parameter ::  p0 = -0.322232431088, p1 = -1.0, p2=-0.342242088547
            real*8, parameter ::  p3 = -0.0204231210245, p4 = -0.0000453642210148
            real*8, parameter ::  q0 = 0.0993484626060, q1 = 0.588581570495, q2 = 0.531103462366
            real*8, parameter ::  q3 = 0.103537752850, q4 = 0.0038560700634

            ! Check for an error situation:

            ierror = 1
            if(p < lim) then
                xp = -1.0e10
                return
            end if
            if(p > (1.0-lim)) then
                xp =  1.0e10
                return
            end if
            ierror = 0

            ! Get k for an error situation:

            pp   = p
            if(p > 0.5) pp = 1 - pp
            xp   = 0.0
            if(p == 0.5) return

            ! Approximate the function:

            y  = dsqrt(dlog(1.0/(pp*pp)))

            xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) / ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )

            if(real(p) == real(pp)) xp = -xp

        end subroutine gauinv

        pure real function backtr(vrgs,nt,vr,vrg,zmin,zmax,ltail,ltpar, utail,utpar)
            !-----------------------------------------------------------------------
            !           Back Transform Univariate Data from Normal Scores
            !           *************************************************
            ! This subroutine backtransforms a standard normal deviate from a
            ! specified back transform table and option for the tails of the
            ! distribution.  Call once with "first" set to true then set to false
            ! unless one of the options for the tail changes.

            ! INPUT VARIABLES:
            !   vrgs             normal score value to be back transformed
            !   nt               number of values in the back transform tbale
            !   vr(nt)           original data values that were transformed
            !   vrg(nt)          the corresponding transformed values
            !   zmin,zmax        limits possibly used for linear or power model
            !   ltail            option to handle values less than vrg(1):
            !   ltpar            parameter required for option ltail
            !   utail            option to handle values greater than vrg(nt):
            !   utpar            parameter required for option utail
            !
            !-----------------------------------------------------------------------

            ! inputs
            integer, intent (in) :: nt, ltail, utail
            real, dimension(nt), intent (in) ::  vr, vrg
            real, intent (in) ::    ltpar, utpar, vrgs, zmin,zmax

            ! internal variables
            real :: lambda, cdflo, cdfbt, cpow, cdfhi
            integer :: j

            ! Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid)

            if(vrgs <= vrg(1)) then
                backtr = vr(1)
                cdflo  = gcum(vrg(1))
                cdfbt  = gcum(vrgs)
                if(ltail == 1) then
                    backtr = powint(0.0,cdflo,zmin,vr(1),cdfbt,1.0)
                else if(ltail == 2) then
                    cpow   = 1.0 / ltpar
                    backtr = powint(0.0,cdflo,zmin,vr(1),cdfbt,cpow)
                endif

            ! Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:

            else if(vrgs >= vrg(nt)) then
                backtr = vr(nt)
                cdfhi  = gcum(vrg(nt))
                cdfbt  = gcum(vrgs)
                if(utail == 1) then
                    backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,1.0)
                else if(utail == 2) then
                    cpow   = 1.0 / utpar
                    backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,cpow)
                else if(utail == 4) then
                    lambda = (vr(nt)**utpar)*(1.0-gcum(vrg(nt)))
                    backtr = (lambda/(1.0-gcum(vrgs)))**(1.0/utpar)
                endif
            else

            ! Value within the transformation table:

                j = locate(vrg,nt,1,nt,vrgs)
                j = max(min((nt-1),j),1)
                backtr = powint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs,1.0)

            endif

            ! there is a finction call getz, which is equal to this function except for this two lines
            !if(getz < zmin) getz = zmin
            !if(getz > zmax) getz = zmax
            ! getz is only used in trans.f90

        end function backtr

        pure elemental real function gcum(x)
            !-----------------------------------------------------------------------
            ! Evaluate the standard normal cdf given a normal deviate x.  gcum is
            ! the area under a unit normal curve to the left of x.  The results are
            ! accurate only to about 5 decimal places.
            !-----------------------------------------------------------------------

            !inputs
            real, intent(in) :: x

            !internal variables
            real :: z, t, e2

            z = x
            if(z < 0.) z = -z
            t    = 1./(1.+ 0.2316419*z)
            gcum = t*(0.31938153   + t*(-0.356563782 + t*(1.781477937 + &
            t*(-1.821255978 + t*1.330274429))))
            e2   = 0.

            !  6 standard deviations out gets treated as infinity:

            if(z <= 6.) e2 = exp(-z*z/2.)*0.3989422803
            gcum = 1.0- e2 * gcum
            if(x >= 0.) return
            gcum = 1.0 - gcum

        end function gcum

        pure elemental real function powint(xlow,xhigh,ylow,yhigh,xval,pow)
            !-----------------------------------------------------------------------
            ! Power interpolate the value of y between (xlow,ylow) and (xhigh,yhigh)
            !                 for a value of x and a power pow.
            !-----------------------------------------------------------------------

            ! input variables
            real, intent(in) :: xlow, xhigh, ylow, yhigh, xval, pow

            if((xhigh-xlow) < EPSLON) then
                powint = (yhigh+ylow)/2.0
            else
                powint = ylow + (yhigh-ylow)*(((xval-xlow)/(xhigh-xlow))**pow)
            end if

        end function powint

        pure elemental real*8 function dpowint(xlow,xhigh,ylow,yhigh,xval,pow)
            !-----------------------------------------------------------------------
            ! Power interpolate the value of y between (xlow,ylow) and (xhigh,yhigh)
            !                 for a value of x and a power pow.
            !-----------------------------------------------------------------------

            ! input variables
            real*8, intent(in) :: xlow, xhigh, ylow, yhigh, xval, pow

            if((xhigh-xlow) < EPSLON) then
                dpowint = (yhigh+ylow)/2.0
            else
                dpowint = ylow + (yhigh-ylow)*(((xval-xlow)/(xhigh-xlow))**pow)
            end if

        end function dpowint

        pure integer function locate(xx,n,is,ie,x) result(j)
            !-----------------------------------------------------------------------
            ! Given an array "xx" of length "n", and given a value "x", this routine
            ! returns a value "j" such that "x" is between xx(j) and xx(j+1).  xx
            ! must be monotonic, either increasing or decreasing.  j=is-1 or j=ie is
            ! returned to indicate that x is out of range.
            !
            ! Bisection Concept From "Numerical Recipes", Press et. al. 1986  pp 90.
            !-----------------------------------------------------------------------

            ! input variables
            integer, intent (in):: n, is, ie
            real, intent (in) :: x
            real, intent (in), dimension(n) :: xx

            !internal variable
            integer :: jl, ju, jm, iss

            ! make internal copy of is
            iss = is

            ! Initialize lower and upper methods:

            if(iss <= 0) iss = 1
            jl = is-1
            ju = ie
            if(xx(n) <= x) then
                j = ie
                return
            end if

            ! If we are not done then compute a midpoint:

            10 if(ju-jl > 1) then
                jm = (ju+jl)/2

                ! Replace the lower or upper limit with the midpoint:

                if((xx(ie) > xx(iss)).eqv.(x > xx(jm))) then
                    jl = jm
                else
                    ju = jm
                endif
                go to 10
            endif

            ! Return with the array index:

            j = jl

            return

        end function locate

        pure integer function dlocate(xx,n,is,ie,x) result(j)
            !-----------------------------------------------------------------------
            ! Given an array "xx" of length "n", and given a value "x", this routine
            ! returns a value "j" such that "x" is between xx(j) and xx(j+1).  xx
            ! must be monotonic, either increasing or decreasing.  j=is-1 or j=ie is
            ! returned to indicate that x is out of range.
            !
            ! Bisection Concept From "Numerical Recipes", Press et. al. 1986  pp 90.
            !-----------------------------------------------------------------------

            ! input variables
            integer, intent (in):: n, is, ie
            real*8, intent (in) :: x
            real*8, intent (in), dimension(n) :: xx

            !internal variable
            integer :: jl, ju, jm, iss

            ! make internal copy of is
            iss = is

            ! Initialize lower and upper methods:

            if(iss <= 0) iss = 1
            jl = is-1
            ju = ie
            if(xx(n) <= x) then
                j = ie
                return
            end if

            ! If we are not done then compute a midpoint:

            10 if(ju-jl > 1) then
                jm = (ju+jl)/2

                ! Replace the lower or upper limit with the midpoint:

                if((xx(ie) > xx(iss)).eqv.(x > xx(jm))) then
                    jl = jm
                else
                    ju = jm
                endif
                go to 10
            endif

            ! Return with the array index:

            j = jl

            return

        end function dlocate

        pure subroutine beyond(ivtype,nccut,ccut,ccdf,ncut,cut,cdf,zmin,zmax, &
            ltail,ltpar,middle,mpar,utail,utpar,zval,cdfval,ierr)
            !-----------------------------------------------------------------------
            !                     Go Beyond a Discrete CDF
            !                     ************************
            ! This subroutine is a general purpose subroutine to interpolate within
            ! and extrapolate beyond discrete points on a conditional CDF.  If the
            ! Z value "zval" is specified then the corresponding CDF value "cdfval"
            ! will be computed, if the CDF value "cdfval" is specified the
            ! corresponding Z value "zval" will be computed.

            ! INPUT/OUTPUT VARIABLES:
            !   ivtype           variable type (1=continuous, 0=categorical)
            !   nccut            number of cutoffs defining the conditional CDF
            !   ccut()           real array of the nccut cutoffs
            !   ccdf()           real array of the conditional cdf values
            !   ncut             number of cutoffs defining the global CDF
            !   cut()            real array of the ncut cutoffs
            !   cdf()            real array of the global cdf values
            !   zmin,zmax        minimum and maximum allowable data values
            !   ltail            option to handle values in lower tail
            !   ltpar            parameter required for option ltail
            !   middle           option to handle values in the middle
            !   mpar             parameter required for option middle
            !   utail            option to handle values in upper tail
            !   utpar            parameter required for option utail
            !   output variables
            !   zval             interesting cutoff (if -1 then it is calculated)
            !   cdfval           interesting CDF (if -1 then it is calculated)
            !   ierr             error code
            !       1            zval > UNEST .AND. cdfval > UNEST,
            !                    or zval <= UNEST .AND. cdfval <= UNEST
            !       2            Unacceptable input option
            !-----------------------------------------------------------------------

            ! Input variables
            integer, intent (in) :: ivtype, nccut, ncut
            real, intent (in), dimension (ncut):: ccut, ccdf
            real, intent (in), dimension (1):: cut, cdf       !consider using scalar here
            real, intent (in):: zmin, zmax, ltpar, utpar, mpar
            integer, intent (in):: ltail, middle, utail

            !output variable
            integer, intent (out):: ierr
            real, intent (out):: zval, cdfval

            !  Internal variables
            integer ::   cclow,cchigh, i, ipart, idat, iupp, ilow
            real :: cum, powr, temp, lambda

            ! Check for both "zval" and "cdfval" defined or undefined:

            ierr  = 1
            if(zval > UNEST .AND. cdfval > UNEST) return
            if(zval <= UNEST .AND. cdfval <= UNEST) return

            ! Handle the case of a categorical variable:

            if(ivtype == 0) then
                cum = 0
                do i=1,nccut
                    cum = cum + ccdf(i)
                    if(cdfval <= cum) then
                        zval = ccut(i)
                        return
                    endif
                end do
                return
            end if

            ! Figure out what part of distribution: ipart = 0 - lower tail
            !                                       ipart = 1 - middle
            !                                       ipart = 2 - upper tail
            ierr  = 0
            ipart = 1
            if(zval > UNEST) then
                if(zval <= ccut(1))       ipart = 0
                if(zval >= ccut(nccut))   ipart = 2
            else
                if(cdfval <= ccdf(1))     ipart = 0
                if(cdfval >= ccdf(nccut)) ipart = 2
            endif

            ! ARE WE IN THE LOWER TAIL?

            if(ipart == 0) then
                if(ltail == 1) then

                    ! Straight Linear Interpolation:

                    powr = 1.0
                    if(zval > UNEST) then
                        cdfval = powint(zmin,ccut(1),0.0,ccdf(1), &
                        zval,powr)
                    else
                        zval = powint(0.0,ccdf(1),zmin,ccut(1), &
                        cdfval,powr)
                    endif
                else if(ltail == 2) then

                    ! Power Model interpolation to lower limit "zmin"?

                    if(zval > UNEST) then
                        cdfval = powint(zmin,ccut(1),0.0,ccdf(1), &
                        zval,ltpar)
                    else
                        powr = 1.0 / ltpar
                        zval = powint(0.0,ccdf(1),zmin,ccut(1), &
                        cdfval,powr)
                    endif

                    ! Linear interpolation between the rescaled global cdf?

                else if(ltail == 3) then
                    if(zval > UNEST) then

                        ! Computing the cdf value. Locate the point and the class bound:

                        idat = locate(cut,ncut,1,ncut,zval)
                        iupp = locate(cut,ncut,1,ncut,ccut(1))

                        ! Straight linear interpolation if no data; otherwise, linear:

                        if(idat <= 0 .OR. idat >= ncut .OR. &
                        iupp <= 0 .OR. iupp >= ncut) then
                            cdfval = powint(zmin,cut(1),0.0,cdf(1), &
                            zval,1.)
                        else
                            temp   = powint(cut(idat),cut(idat+1), &
                            cdf(idat),cdf(idat+1),zval,1.)
                            cdfval = temp*ccdf(1)/cdf(iupp)
                        endif
                    else

                        ! Computing Z value: Are there any data out in the tail?

                        iupp = locate(cut,ncut,1,ncut,ccut(1))

                        ! Straight linear interpolation if no data; otherwise, local linear
                        ! interpolation:

                        if(iupp <= 0 .OR. iupp >= ncut) then
                            zval = powint(0.0,cdf(1),zmin,cut(1), &
                            cdfval,1.)
                        else
                            temp = cdfval*cdf(iupp)/ccdf(1)
                            idat = locate(cdf,ncut,1,ncut,temp)
                            if(idat <= 0 .OR. idat >= ncut) then
                                zval = powint(0.0,cdf(1),zmin, &
                                cut(1),cdfval,1.)
                            else
                                zval = powint(cdf(idat),cdf(idat+1), &
                                cut(idat),cut(idat+1),temp,1.)
                            end if
                        endif
                    endif
                else

                    ! Error situation - unacceptable option:

                    ierr = 2
                    return
                endif
            endif

            ! FINISHED THE LOWER TAIL,  ARE WE IN THE MIDDLE?

            if(ipart == 1) then

                ! Establish the lower and upper limits:

                if(zval > UNEST) then
                    cclow = locate(ccut,nccut,1,nccut,zval)
                else
                    cclow = locate(ccdf,nccut,1,nccut,cdfval)
                endif
                cchigh = cclow + 1
                if(middle == 1) then

                    ! Straight Linear Interpolation:

                    powr = 1.0
                    if(zval > UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh), &
                        ccdf(cclow),ccdf(cchigh),zval,powr)
                    else
                        zval = powint(ccdf(cclow),ccdf(cchigh), &
                        ccut(cclow),ccut(cchigh),cdfval,powr)
                    endif

                    ! Power interpolation between class bounds?

                else if(middle == 2) then
                    if(zval > UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh), &
                        ccdf(cclow),ccdf(cchigh),zval,mpar)
                    else
                        powr = 1.0 / mpar
                        zval = powint(ccdf(cclow),ccdf(cchigh), &
                        ccut(cclow),ccut(cchigh),cdfval,powr)
                    endif

                    ! Linear interpolation between the rescaled global cdf?

                else if(middle == 3) then
                    ilow = locate(cut,ncut,1,ncut,ccut(cclow))
                    iupp = locate(cut,ncut,1,ncut,ccut(cchigh))
                    if(cut(ilow) < ccut(cclow))  ilow = ilow + 1
                    if(cut(iupp) > ccut(cchigh)) iupp = iupp - 1
                    if(zval > UNEST) then
                        idat = locate(cut,ncut,1,ncut,zval)

                        ! Straight linear interpolation if no data; otherwise, local linear
                        ! interpolation:

                        if(idat <= 0 .OR. idat >= ncut .OR. &
                        ilow <= 0 .OR. ilow >= ncut .OR. &
                        iupp <= 0 .OR. iupp >= ncut .OR. &
                        iupp <= ilow) then
                            cdfval=powint(ccut(cclow),ccut(cchigh), &
                            ccdf(cclow),ccdf(cchigh),zval,1.)
                        else
                            temp = powint(cut(idat),cut(idat+1), &
                            cdf(idat),cdf(idat+1),zval,1.)
                            cdfval=powint(cdf(ilow),cdf(iupp), &
                            ccdf(cclow),ccdf(cchigh),temp,1.)
                        endif
                    else

                        ! Straight linear interpolation if no data; otherwise, local linear
                        ! interpolation:

                        if(ilow <= 0 .OR. ilow >= ncut .OR. &
                        iupp <= 0 .OR. iupp >= ncut .OR. &
                        iupp <= ilow) then
                            zval=powint(ccdf(cclow),ccdf(cchigh), &
                            ccut(cclow),ccut(cchigh),cdfval,1.)
                        else
                            temp=powint(ccdf(cclow),ccdf(cchigh), &
                            cdf(ilow),cdf(iupp),cdfval,1.)
                            idat = locate(cdf,ncut,1,ncut,temp)
                            if(cut(idat) < ccut(cclow)) idat=idat+1
                            if(idat <= 0 .OR. idat >= ncut .OR. &
                            cut(idat+1) > ccut(cchigh)) then
                                zval = powint(ccdf(cclow), &
                                ccdf(cchigh),ccut(cclow), &
                                ccut(cchigh),cdfval,1.)
                            else
                                zval = powint(cdf(idat),cdf(idat+1), &
                                cut(idat),cut(idat+1),temp,1.)
                            end if
                            zval = powint(cdf(idat),cdf(idat+1), &
                            cut(idat),cut(idat+1),temp,1.)
                        endif
                    endif
                else

                    ! Error situation - unacceptable option:

                    ierr = 2
                    return
                endif
            endif

            ! FINISHED THE MIDDLE,  ARE WE IN THE UPPER TAIL?

            if(ipart == 2) then
                if(utail == 1) then
                    powr = 1.0
                    if(zval > UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut), &
                        &                                   1.0,zval,powr)
                    else
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut), &
                        zmax,cdfval,powr)
                    endif

                else if(utail == 2) then

                    ! Power interpolation to upper limit "utpar"?

                    if(zval > UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut), &
                        &                                   1.0,zval,utpar)
                    else
                        powr = 1.0 / utpar
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut), &
                        zmax,cdfval,powr)
                    endif

                    ! Linear interpolation between the rescaled global cdf?

                else if(utail == 3) then
                    if(zval > UNEST) then

                        ! Approximately Locate the point and the class bound:

                        idat = locate(cut,ncut,1,ncut,zval)
                        ilow = locate(cut,ncut,1,ncut,ccut(nccut))
                        if(cut(idat) < zval)        idat = idat + 1
                        if(cut(ilow) < ccut(nccut)) ilow = ilow + 1

                        ! Straight linear interpolation if no data; otherwise, local linear
                        ! interpolation:

                        if(idat <= 0 .OR. idat >= ncut .OR. &
                        ilow <= 0 .OR. ilow >= ncut) then
                            cdfval = powint(ccut(nccut),zmax, &
                            ccdf(nccut),1.0,zval,1.)
                        else
                            temp   = powint(cut(idat),cut(idat+1), &
                            cdf(idat),cdf(idat+1),zval,1.)
                            cdfval = powint(cdf(ilow),1.0, &
                            ccdf(nccut),1.0,temp,1.)
                        endif
                    else

                        ! Computing Z value: Are there any data out in the tail?

                        ilow = locate(cut,ncut,1,ncut,ccut(nccut))
                        if(cut(ilow) < ccut(nccut)) ilow = ilow + 1

                        ! Straight linear interpolation if no data; otherwise, local linear
                        ! interpolation:

                        if(ilow <= 0 .OR. ilow >= ncut) then
                            zval   = powint(ccdf(nccut),1.0, &
                            ccut(nccut),zmax,cdfval,1.)
                        else
                            temp = powint(ccdf(nccut),1.0, &
                            cdf(ilow),1.0,cdfval,1.)
                            idat = locate(cdf,ncut,1,ncut,temp)
                            if(cut(idat) < ccut(nccut)) idat=idat+1
                            if(idat >= ncut) then
                                zval   = powint(ccdf(nccut),1.0, &
                                ccut(nccut),zmax,cdfval,1.)
                            else
                                zval = powint(cdf(idat),cdf(idat+1), &
                                cut(idat),cut(idat+1),temp,1.)
                            endif
                        endif
                    endif

                    ! Fit a Hyperbolic Distribution?

                else if(utail == 4) then

                    ! Figure out "lambda" and required info:

                    lambda = (ccut(nccut)**utpar)*(1.0-ccdf(nccut))
                    if(zval > UNEST) then
                        cdfval = 1.0 - (lambda/(zval**utpar))
                    else
                        zval = (lambda/(1.0-cdfval))**(1.0/utpar)
                    endif
                else

                    ! Error situation - unacceptable option:

                    ierr = 2
                    return
                endif
            endif
            if(zval < zmin) zval = zmin
            if(zval > zmax) zval = zmax

            ! All finished - return:

            return

        end subroutine beyond

        pure real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,nrotmat,rotmat)
            !-----------------------------------------------------------------------
            !    Squared Anisotropic Distance Calculation Given Matrix Indicator
            !    ***************************************************************
            !
            !  This routine calculates the anisotropic distance between two points
            !  given the coordinates of each point and a definition of the
            !  anisotropy.
            !
            ! INPUT VARIABLES:
            !
            !   x1,y1,z1         Coordinates of first point
            !   x2,y2,z2         Coordinates of second point
            !   ind              The rotation matrix to use
            !   nrotmat          The maximum number of rotation matrices dimensioned
            !   rotmat           The rotation matrices
            !
            ! OUTPUT VARIABLES:
            !   sqdist           The squared distance accounting for the anisotropy
            !                      and the rotation of coordinates (if any).
            !
            ! NO EXTERNAL REFERENCES
            !-----------------------------------------------------------------------

            ! input variables variables
            integer, intent(in) :: nrotmat, ind
            real*8, intent(in), dimension(nrotmat,3,3) :: rotmat
            real, intent(in) :: x1,y1,z1, x2,y2, z2

            ! internal variables
            real*8 :: cont,dx,dy,dz
            integer :: i
            ! Compute component distance vectors and the squared distance:

            dx = dble(x1 - x2)
            dy = dble(y1 - y2)
            dz = dble(z1 - z2)
            sqdist = 0.0
            do i=1,3
                cont   = rotmat(ind,i,1) * dx &
                + rotmat(ind,i,2) * dy &
                + rotmat(ind,i,3) * dz
                sqdist = sqdist + cont * cont
            end do
            return
        end function

        pure real function cova3(x1,y1,z1,x2,y2,z2,ivarg,nst,c0,it,cc,aa, irot,nrotmat,rotmat, d)
            !-----------------------------------------------------------------------
            !                    Covariance Between Two Points
            !                    *****************************
            ! This subroutine calculated the covariance associated with a variogram
            ! model specified by a nugget effect and nested varigoram structures.
            ! The anisotropy definition can be different for each nested structure.
            !
            ! INPUT VARIABLES:
            !   x1,y1,z1         coordinates of first point
            !   x2,y2,z2         coordinates of second point
            !   nst              number of nested structures (maximum of 4)
            !   ivarg            variogram number (set to 1 unless doing cokriging
            !                       or indicator kriging)
            !   c0(ivarg)        isotropic nugget constant
            !   it(i)            type of each nested structure:
            !                      1. spherical model of range a;
            !                      2. exponential model of parameter a;
            !                           i.e. practical range is 3a
            !                      3. gaussian model of parameter a;
            !                           i.e. practical range is a*sqrt(3)
            !                      4. power model of power a (a must be gt. 0  and
            !                           lt. 2).  if linear model, a=1,c=slope.
            !                      5. hole effect model
            !   cc(i)            multiplicative factor of each nested structure.
            !                      (sill-c0) for spherical, exponential,and gaussian
            !                      slope for linear model.
            !   aa(i)            parameter "a" of each nested structure.
            !   irot             index of the rotation matrix for the first nested
            !                    structure (the second nested structure will use
            !                    irot+1, the third irot+2, and so on)
            !   nrotmat          size of rotation matrix arrays
            !   rotmat           rotation matrices
            !
            ! OUTPUT VARIABLES:
            !   cmax             maximum covariance
            !   cova             covariance between (x1,y1,z1) and (x2,y2,z2)
            !
            ! EXTERNAL REFERENCES: sqdist    computes anisotropic squared distance
            !                      rotmat    computes rotation matrix for distance
            !
            ! Change from old code:
            !    -nst is now a sclar instead of an array, and all the variograms will
            !     have the same number of structures (nst). The sise of the arrays
            !     is nst*ivarg
            !    -size of the rotation matrix renemed to nrotmat
            !    -removed output cmax, which is not used in any other gslib program
            !    -turned cova3 into function
            !    -parameter d for damped hole effect added
            !-----------------------------------------------------------------------

            ! input variables
            real, intent(in) :: x1,y1,z1,x2,y2,z2          ! coordinates of the two points
            integer, intent(in) :: ivarg, irot, nst, nrotmat
            real, intent(in), dimension(ivarg) ::c0
            real, intent(in), dimension(nst*ivarg) :: it,cc,aa
            real*8, intent(in), dimension(nrotmat,3,3) :: rotmat
            real, intent(in), optional :: d

            ! internal variables
            real*8 :: hsqd
            real :: cmax, h, hr
            integer :: istart, is, ist, ir

            ! Calculate the maximum covariance value (used for zero distances and
            ! for power model covariance):

            istart = 1 + (ivarg-1)*nrotmat
            cmax   = c0(ivarg)
            do is=1,nst
                ist = istart + is - 1
                if(it(ist) == 4) then
                    cmax = cmax + PMX
                else
                    cmax = cmax + cc(ist)
                endif
            end do

            ! Check for "zero" distance, return with cmax if so:

            hsqd = sqdist(x1,y1,z1,x2,y2,z2,irot,nrotmat,rotmat)
            if(real(hsqd) < EPSLON) then
                cova3 = cmax
                return
            endif

            ! Loop over all the structures:

            cova3 = 0.0
            do is=1,nst
                ist = istart + is - 1

                ! Compute the appropriate distance:
                if(ist /= 1) then
                    ir = min((irot+is-1),nrotmat)
                    hsqd=sqdist(x1,y1,z1,x2,y2,z2,ir,nrotmat,rotmat)
                end if
                h = real(dsqrt(hsqd))

                ! Spherical Variogram Model?
                if(it(ist) == 1) then
                    hr = h/aa(ist)
                    if(hr < 1.) cova3=cova3+cc(ist)*(1.-hr*(1.5-.5*hr*hr))

                ! Exponential Variogram Model?
                else if(it(ist) == 2) then
                    cova3 = cova3 + cc(ist)*exp(-3.0*h/aa(ist))

                ! Gaussian Variogram Model?
                else if(it(ist) == 3) then
                    cova3 = cova3 + cc(ist)*exp(-3.*(h/aa(ist))*(h/aa(ist)))

                ! Power Variogram Model?
                else if(it(ist) == 4) then
                    cova3 = cova3 + cmax - cc(ist)*(h**aa(ist))

                ! Hole Effect Model?
                else if(it(ist) == 5) then
                    cova3 = cova3 + cc(ist)*cos(h/aa(ist)*PI)

                ! Damped Hole Effect Model?
                else if(it(ist) == 6) then

                    if(present(d)) then
                        cova3 = cova3 + cc(ist)*exp(-3.0*h/d)*cos(h/aa(ist)*PI)
                    else
                        ! d is the distance where 95% of the hole effect is dampened out.
                        ! Here we assume d is 10 times the range.
                        cova3 = cova3 + cc(ist)*exp(-3.0*h/(10.0 * aa(ist)))*cos(h/aa(ist)*PI)
                    end if

                ! TODO: add here Cauchy model, Matern model, Logistic model (rational quadratic model), Generalised Cauchy, Spheroidal

                end if

            end do

            ! Finished:

        end function cova3

        pure elemental integer function getindx(min,siz,loc) result (index)
            !-----------------------------------------------------------------------
            !     Gets the coordinate index location of a point within a grid
            !     ***********************************************************
            ! min     origin at the center of the first cell
            ! siz     size of the cells
            ! loc     location of the point being considered
            ! index   output index within [1,n]
            !-----------------------------------------------------------------------

            ! inputs
            real, intent (in) :: min,siz,loc

            ! Compute the index of "loc":
            index = int( (loc-min)/siz + 1.5 )

        end function getindx

        pure subroutine setrot(ang1,ang2,ang3,anis1,anis2,ind,nrotmat,rotmat)
            !-----------------------------------------------------------------------
            !              Sets up an Anisotropic Rotation Matrix
            !              **************************************
            !
            ! Sets up the matrix to transform cartesian coordinates to coordinates
            ! accounting for angles and anisotropy (see manual for a detailed
            ! definition):
            !
            ! INPUT PARAMETERS:
            !   ang1             Azimuth angle for principal direction
            !   ang2             Dip angle for principal direction
            !   ang3             Third rotation angle
            !   anis1            First anisotropy ratio
            !   anis2            Second anisotropy ratio
            !   ind              matrix indicator to initialize
            !   nrotmat          maximum number of rotation matrices dimensioned
            !   rotmat           rotation matrices
            !-----------------------------------------------------------------------

            ! inputs
            integer, intent (in) :: nrotmat, ind
            real, intent (in) :: ang1,ang2,ang3,anis1,anis2

            !output
            real*8, intent (inout), dimension(nrotmat,3,3) :: rotmat

            !internal
            real*8 :: afac1,afac2,sina,sinb,sint, cosa,cosb,cost
            real :: alpha, beta, theta

            ! Converts the input angles to three angles which make more
            !  mathematical sense:

            !         alpha   angle between the major axis of anisotropy and the
            !                 E-W axis. Note: Counter clockwise is positive.
            !         beta    angle between major axis and the horizontal plane.
            !                 (The dip of the ellipsoid measured positive down)
            !         theta   Angle of rotation of minor axis about the major axis
            !                 of the ellipsoid.

            if(ang1 >= 0.0 .AND. ang1 < 270.0) then
                alpha = (90.0   - ang1) * DEG2RAD
            else
                alpha = (450.0  - ang1) * DEG2RAD
            endif
            beta  = -1.0 * ang2 * DEG2RAD
            theta =        ang3 * DEG2RAD

            ! Get the required sines and cosines:

            sina  = dble(sin(alpha))
            sinb  = dble(sin(beta))
            sint  = dble(sin(theta))
            cosa  = dble(cos(alpha))
            cosb  = dble(cos(beta))
            cost  = dble(cos(theta))

            ! Construct the rotation matrix in the required memory:

            afac1 = 1.0 / dble(max(anis1,EPSLON))
            afac2 = 1.0 / dble(max(anis2,EPSLON))
            rotmat(ind,1,1) =       (cosb * cosa)
            rotmat(ind,1,2) =       (cosb * sina)
            rotmat(ind,1,3) =       (-sinb)
            rotmat(ind,2,1) = afac1*(-cost*sina + sint*sinb*cosa)
            rotmat(ind,2,2) = afac1*(cost*cosa + sint*sinb*sina)
            rotmat(ind,2,3) = afac1*( sint * cosb)
            rotmat(ind,3,1) = afac2*(sint*sina + cost*sinb*cosa)
            rotmat(ind,3,2) = afac2*(-sint*cosa + cost*sinb*sina)
            rotmat(ind,3,3) = afac2*(cost * cosb)

        end subroutine setrot

        pure subroutine ordrel(ivtype,ncut,ccdf,ccdfo,nviol,aviol,xviol)
            !-----------------------------------------------------------------------
            !                 Correct Order Relation Problems
            !                 *******************************
            ! This subroutine identifies and corrects order relation problems in a
            ! conditional distribution known at a specified number of cutoffs.
            !
            ! INPUT VARIABLES:
            !   ivtype           variable type (0=categorical, 1=continuous)
            !   ncut             number of cutoffs
            !   ccdf(i)          input ccdf values
            !
            ! OUTPUT VARIABLES:
            !   ccdfo            corrected ccdf values
            !   nviol()          number of order relation violations
            !   aviol()          average magnitude of the order relation violations
            !   xviol()          maximum magnitude of the order relation violations
            !
            ! PROGRAMMING NOTES:
            !
            !   1. the arrays ccdf1 and ccdf2 are used for temporary storage of the
            !      ccdf corrected sequentially upwards and downwards.  The program
            !      execution will be stopped if the memory allocation of these two
            !      arrays is not sufficient.
            !-----------------------------------------------------------------------

            ! inputs
            integer, intent(in) :: ncut, ivtype
            real, intent(in), dimension(ncut) :: ccdf

            ! outputs
            real, intent(out), dimension(ncut) :: ccdfo, aviol, xviol
            integer, intent(out), dimension(ncut) :: nviol

            ! internals
            real, dimension(ncut) :: ccdf1(ncut), ccdf2(ncut)
            integer :: i
            real :: sumcdf, viol

            ! Make sure conditional cdf is within [0,1]:

            do i=1,ncut
                if(ccdf(i) < 0.0) then
                    ccdf1(i) = 0.0
                    ccdf2(i) = 0.0
                else if(ccdf(i) > 1.0) then
                    ccdf1(i) = 1.0
                    ccdf2(i) = 1.0
                else
                    ccdf1(i) = ccdf(i)
                    ccdf2(i) = ccdf(i)
                endif
            end do

            ! Correct sequentially up, then down, and then average:

            if(ivtype == 0) then
                sumcdf = 0.0
                do i=1,ncut
                    sumcdf = sumcdf + ccdf1(i)
                end do
                if(sumcdf <= 0.0) sumcdf = 1.0
                do i=1,ncut
                    ccdfo(i) = ccdf1(i) / sumcdf
                end do
            else
                do i=2,ncut
                    if(ccdf1(i) < ccdf1(i-1)) ccdf1(i) = ccdf1(i-1)
                end do
                do i=ncut-1,1,-1
                    if(ccdf2(i) > ccdf2(i+1)) ccdf2(i) = ccdf2(i+1)
                end do
                do i=1,ncut
                    ccdfo(i) = 0.5*(ccdf1(i)+ccdf2(i))
                end do
            end if

            ! Accumulate error statistics:

            do i=1,ncut
                if(ccdf(i) /= ccdfo(i)) then
                    viol = abs(ccdf(i)-ccdfo(i))
                    nviol(i) = nviol(i) + 1
                    aviol(i) = aviol(i) + viol
                    xviol(i) = max(xviol(i),viol)
                endif
            end do

        end subroutine ordrel

end module gslib

! test functions

subroutine test_qsort()
    use gslib
    implicit none
    real, dimension (5) :: x = [3,5,2,1,8]
    integer, dimension (5) :: ind = [1,2,3,4,5]

    call QSort(5,x,ind)
    print *,  x
    print *,  ind

end subroutine test_qsort

subroutine test_ulcg()
    use gslib
    implicit none
    integer :: error, i
    real, dimension (5) :: x
    integer, dimension (5) :: ind
    integer(i64) :: seed = 87687, old_state

    error = 1

    !$OMP PARALLEL private(seed, old_state, x, i, ind)

    old_state = lcg(seed)
    do i=1 , 5
        old_state = lcg(old_state)
        x(i) = ulcg(old_state)
    end do
    call QSort(5,x,ind)
    print *,  x

    !$OMP END PARALLEL

end subroutine test_ulcg

program test_gslib
    use gslib
    implicit none

    print *, 'test qsort'

    call  test_qsort()

end program


module interp_module

  use bl_types
  use bl_constants_module
  use bc_module

  implicit none

  private :: ix_proj

contains

  elemental function ix_proj(a,b) result(r)
    integer :: r
    integer, intent(in) :: a, b
    r = (a+b*abs(a))/b-abs(a)
  end function ix_proj

  !! lin_cc_interp:   linear conservative interpolation from coarse grid to fine

  subroutine lin_cc_interp_1d (fine, fine_lo, crse, crse_lo, &
                               lratio, bc, &
                               fvcx, fvcx_lo, cvcx, cvcx_lo, &
                               cslope_lo, cslope_hi, lim_slope, lin_limit)

    integer, intent(in) ::   fine_lo(:),  crse_lo(:)
    integer, intent(in) :: cslope_lo(:),cslope_hi(:)
    integer, intent(in) :: lratio(:)
    integer, intent(in) :: bc(:,:,:)
    integer, intent(in) :: fvcx_lo,cvcx_lo
    logical, intent(in) :: lim_slope, lin_limit
    real(kind=dp_t), intent(  out) :: fine(fine_lo(1):,:)
    real(kind=dp_t), intent(inout) :: crse(crse_lo(1):,:)
    real(kind=dp_t), intent(in   ) :: fvcx(fvcx_lo:)
    real(kind=dp_t), intent(in   ) :: cvcx(cvcx_lo:)

    real(kind=dp_t) ::     uc_xslope(cslope_lo(1):cslope_hi(1),size(fine,2))
    real(kind=dp_t) ::     lc_xslope(cslope_lo(1):cslope_hi(1),size(fine,2))
    real(kind=dp_t) :: xslope_factor(cslope_lo(1):cslope_hi(1))
    real(kind=dp_t) ::         alpha(cslope_lo(1):cslope_hi(1),size(fine,2))
    real(kind=dp_t) ::          cmax(cslope_lo(1):cslope_hi(1),size(fine,2))
    real(kind=dp_t) ::          cmin(cslope_lo(1):cslope_hi(1),size(fine,2))
    real(kind=dp_t) ::         voffx(fvcx_lo:fvcx_lo+size(fine,1)-1)

    integer :: n
    integer :: i, ic
    real(kind=dp_t) :: fxcen, cxcen
    real(kind=dp_t) :: orig_corr_fact, corr_fact
    logical :: xok(1)
    integer :: nxc(1)
    integer :: ioff

    nxc(1) = size(crse,1)-2

    xok = (nxc >=  2)

    do i = fvcx_lo, fvcx_lo+size(fine,1)-1
       ic = IX_PROJ(i,lratio(1))
       fxcen = HALF*(fvcx(i)+fvcx(i+1))
       cxcen = HALF*(cvcx(ic)+cvcx(ic+1))
       voffx(i) = (fxcen-cxcen)/(cvcx(ic+1)-cvcx(ic))
    end do

    ! Prevent underflow for small crse values.
    where ( abs(crse) <= 1.0e-20_dp_t ) crse = ZERO
    alpha = ONE
    cmax = crse(cslope_lo(1):cslope_hi(1),:)
    cmin = crse(cslope_lo(1):cslope_hi(1),:)

    do n = 1, size(fine,2)
       !
       ! Initialize alpha = 1 and define cmax and cmin as neighborhood max/mins.
       !
       do i = cslope_lo(1), cslope_hi(1)
          do ioff = -1, 1
             cmax(i,n) = max(cmax(i,n),crse(i+ioff,n))
             cmin(i,n) = min(cmin(i,n),crse(i+ioff,n))
          end do
       end do

    end do
    !
    ! Compute unlimited and limited slopes
    !
    do n = 1, size(fine,2)
       do i = cslope_lo(1), cslope_hi(1)
          uc_xslope(i,n) = HALF*(crse(i+1,n)-crse(i-1,n))
          lc_xslope(i,n) = uclc_slope_1d(uc_xslope(i,n),crse,crse_lo,i,n)
       end do

       if ( bc(1,1,n)  ==  EXT_DIR .or. bc(1,1,n) == HOEXTRAP ) then
          i = cslope_lo(1)
          if ( xok(1) ) then
             uc_xslope(i,n) = -SIXTEEN/FIFTEEN*crse(i-1,n)+ HALF*crse(i,n) &
                  + TWO3RD*crse(i+1,n) - TENTH*crse(i+2,n)
          else
             uc_xslope(i,n) = &
                  FOURTH * (crse(i+1,n) + FIVE*crse(i,n) - SIX*crse(i-1,n) )
          end if
          lc_xslope(i,n) = uclc_slope_1d(uc_xslope(i,n),crse,crse_lo,i,n)
       end if

       if ( bc(1,2,n)  ==  EXT_DIR .or. bc(1,2,n) == HOEXTRAP ) then
          i = cslope_hi(1)
          if ( xok(1) ) then
             uc_xslope(i,n) = SIXTEEN/FIFTEEN*crse(i+1,n)- HALF*crse(i,n) &
                  - TWO3RD*crse(i-1,n) + TENTH*crse(i-2,n)
          else
             uc_xslope(i,n) = &
                  -FOURTH * (crse(i-1,n) + FIVE*crse(i,n) - SIX*crse(i+1,n) )
          end if
          lc_xslope(i,n) = uclc_slope_1d(uc_xslope(i,n),crse,crse_lo,i,n)
       end if
    end do

    if ( lim_slope ) then

       if ( lin_limit ) then

          ! compute linear limited slopes
          ! Note that the limited and the unlimited slopes
          ! have the same sign, and it is assumed that they do.

          ! compute slope factors

          xslope_factor = ONE

          do n = 1, size(fine,2)
             where( uc_xslope(:,n) /= 0 )
                xslope_factor = min(xslope_factor,lc_xslope(:,n)/uc_xslope(:,n),ONE)
             end where
          end do

          ! compute linear limited slopes

          do n = 1, size(fine,2)
             lc_xslope(:,n) = xslope_factor*uc_xslope(:,n)
          end do

       else

          ! Limit slopes so as to not introduce new maxs or mins.

          do n = 1, size(fine,2)
             do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
                ic = IX_PROJ(i,lratio(1))

                orig_corr_fact = voffx(i)*lc_xslope(ic,n)
                fine(i,n) = crse(ic,n) + orig_corr_fact
                if ( fine(i,n)  >  cmax(ic,n) ) then
                   if ( abs(orig_corr_fact)  >  1.e-10_dp_t*abs(crse(ic,n)) ) then
                      corr_fact = (cmax(ic,n) - crse(ic,n)) / orig_corr_fact
                      alpha(ic,n) = min(alpha(ic,n),corr_fact)
                   end if
                end if
                if ( fine(i,n)  <  cmin(ic,n) ) then
                   if ( abs(orig_corr_fact)  >  1.e-10_dp_t*abs(crse(ic,n)) ) then
                      corr_fact = (cmin(ic,n) - crse(ic,n)) / orig_corr_fact
                      alpha(ic,n) = min(alpha(ic,n),corr_fact)
                      end if
                end if

             end do
          end do

       end if

       ! Do the interpolation with limited slopes.

       do n = 1, size(fine,2)
          do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
             ic = IX_PROJ(i,lratio(1))

             fine(i,n) = crse(ic,n) + alpha(ic,n)*( &
                  + voffx(i)*lc_xslope(ic,n) )
          end do
       end do

    else

       ! Do the interpolation using unlimited slopes.

       do n = 1, size(fine,2)
          do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
             ic = IX_PROJ(i,lratio(1))
             fine(i,n) = &
                  crse(ic,n) + voffx(i)*uc_xslope(ic,n)
          end do
       end do
    end if

  contains

    function uclc_slope_1d(uslope, crse, crse_lo, i, n) result(lc)

      integer, intent(in) :: crse_lo(:)
      real(kind = dp_t) :: lc
      real(kind=dp_t), intent(in) :: uslope
      real(kind=dp_t), intent(in)  :: crse(crse_lo(1):,:)
      real(kind=dp_t) :: cen, forw, back, slp
      integer, intent(in) :: i,  n
      cen  = uslope
      forw = TWO*(crse(i+1,n)-crse(i,n))
      back = TWO*(crse(i,n)-crse(i-1,n))
      slp  = min(abs(forw),abs(back))
      if ( forw*back  <  ZERO ) then
         slp = ZERO
      end if
      lc = sign(ONE,cen)*min(slp,abs(cen))
    end function uclc_slope_1d

  end subroutine lin_cc_interp_1d

  !! lin_cc_interp:   linear conservative interpolation from coarse grid to fine

  subroutine lin_cc_interp_2d (fine, fine_lo, crse, crse_lo, &
                               lratio, bc, &
                               fvcx, fvcx_lo, fvcy, fvcy_lo, cvcx, cvcx_lo, cvcy, cvcy_lo, &
                               cslope_lo, cslope_hi, lim_slope, lin_limit)

    integer, intent(in) :: fine_lo(:),crse_lo(:)
    integer, intent(in) :: cslope_lo(:),cslope_hi(:)
    integer, intent(in) :: lratio(:)
    integer, intent(in) :: bc(:,:,:)
    integer, intent(in) :: fvcx_lo,fvcy_lo,cvcx_lo,cvcy_lo
    logical, intent(in) :: lim_slope, lin_limit
    real(kind=dp_t), intent(  out) :: fine(fine_lo(1):,fine_lo(2):,:)
    real(kind=dp_t), intent(inout) :: crse(crse_lo(1):,crse_lo(2):,:)
    real(kind=dp_t), intent(in   ) :: fvcx(fvcx_lo:)
    real(kind=dp_t), intent(in   ) :: fvcy(fvcy_lo:)
    real(kind=dp_t), intent(in   ) :: cvcx(cvcx_lo:)
    real(kind=dp_t), intent(in   ) :: cvcy(cvcy_lo:)

    real(kind=dp_t) ::     uc_xslope(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) ::     lc_xslope(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) :: xslope_factor(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2))
    real(kind=dp_t) ::     uc_yslope(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) ::     lc_yslope(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) :: yslope_factor(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2))
    real(kind=dp_t) ::         alpha(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) ::          cmax(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) ::          cmin(cslope_lo(1):cslope_hi(1), &
         cslope_lo(2):cslope_hi(2),size(fine,3))
    real(kind=dp_t) ::         voffx(fvcx_lo:fvcx_lo+size(fine,1)-1)
    real(kind=dp_t) ::         voffy(fvcy_lo:fvcy_lo+size(fine,2)-1)

    integer :: n
    integer :: i, ic
    integer :: j, jc
    real(kind=dp_t) :: fxcen, cxcen, fycen, cycen
    real(kind=dp_t) :: orig_corr_fact, corr_fact
    logical :: xok(2)
    integer :: nxc(2)
    integer :: ioff, joff

    forall (i =1:2) nxc(i) = size(crse,i)-2

    xok = (nxc >=  2)

    do j = fvcy_lo, fvcy_lo+size(fine,2)-1
       jc = IX_PROJ(j,lratio(2))
       fycen = HALF*(fvcy(j)+fvcy(j+1))
       cycen = HALF*(cvcy(jc)+cvcy(jc+1))
       voffy(j) = (fycen-cycen)/(cvcy(jc+1)-cvcy(jc))
    end do
    do i = fvcx_lo, fvcx_lo+size(fine,1)-1
       ic = IX_PROJ(i,lratio(1))
       fxcen = HALF*(fvcx(i)+fvcx(i+1))
       cxcen = HALF*(cvcx(ic)+cvcx(ic+1))
       voffx(i) = (fxcen-cxcen)/(cvcx(ic+1)-cvcx(ic))
    end do

    ! Prevent underflow for small crse values.
    where ( abs(crse) <= 1.0e-20_dp_t ) crse = ZERO
    alpha = ONE
    cmax = crse(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2),:)
    cmin = crse(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2),:)

    do n = 1, size(fine,3)
       !
       ! Initialize alpha = 1 and define cmax and cmin as neighborhood max/mins.
       !
       do j = cslope_lo(2), cslope_hi(2)
          do i = cslope_lo(1), cslope_hi(1)
             do joff = -1, 1
                do ioff = -1, 1
                   cmax(i,j,n) = max(cmax(i,j,n),crse(i+ioff,j+joff,n))
                   cmin(i,j,n) = min(cmin(i,j,n),crse(i+ioff,j+joff,n))
                end do
             end do
          end do
       end do

    end do
    !
    ! Compute unlimited and limited slopes
    !
    do n = 1, size(fine,3)
       do j = cslope_lo(2), cslope_hi(2)
          do i = cslope_lo(1), cslope_hi(1)
             uc_xslope(i,j,n) = HALF*(crse(i+1,j,n)-crse(i-1,j,n))
             lc_xslope(i,j,n) = uclc_slope(uc_xslope(i,j,n),crse,crse_lo,i,j,n,dim=1)
          end do
       end do

       if ( bc(1,1,n)  ==  EXT_DIR .or. bc(1,1,n) == HOEXTRAP ) then
          i = cslope_lo(1)
          if ( xok(1) ) then
             do j = cslope_lo(2), cslope_hi(2)
                uc_xslope(i,j,n) = -SIXTEEN/FIFTEEN*crse(i-1,j,n)+ HALF*crse(i,j,n) &
                     + TWO3RD*crse(i+1,j,n) - TENTH*crse(i+2,j,n)
             end do
          else
             do j = cslope_lo(2), cslope_hi(2)
                uc_xslope(i,j,n) = &
                     FOURTH * (crse(i+1,j,n) + FIVE*crse(i,j,n) - SIX*crse(i-1,j,n) )
             end do
          end if
          do j = cslope_lo(2), cslope_hi(2)
             lc_xslope(i,j,n) = uclc_slope(uc_xslope(i,j,n),crse,crse_lo,i,j,n,dim=1)
          end do
       end if

       if ( bc(1,2,n)  ==  EXT_DIR .or. bc(1,2,n) == HOEXTRAP ) then
          i = cslope_hi(1)
          if ( xok(1) ) then
             do j = cslope_lo(2), cslope_hi(2)
                uc_xslope(i,j,n) = SIXTEEN/FIFTEEN*crse(i+1,j,n)- HALF*crse(i,j,n) &
                     - TWO3RD*crse(i-1,j,n) + TENTH*crse(i-2,j,n)
             end do
          else
             do j = cslope_lo(2), cslope_hi(2)
                uc_xslope(i,j,n) = &
                     -FOURTH * (crse(i-1,j,n) + FIVE*crse(i,j,n) - SIX*crse(i+1,j,n) )
             end do
          end if
          do j = cslope_lo(2), cslope_hi(2)
             lc_xslope(i,j,n) = uclc_slope(uc_xslope(i,j,n),crse,crse_lo,i,j,n, dim=1)
          end do
       end if

       do j = cslope_lo(2), cslope_hi(2)
          do i = cslope_lo(1), cslope_hi(1)
             uc_yslope(i,j,n) = HALF*(crse(i,j+1,n)-crse(i,j-1,n))
             lc_yslope(i,j,n) = uclc_slope(uc_yslope(i,j,n),crse,crse_lo,i,j,n,dim=2)
          end do
       end do

       if ( bc(2,1,n)  == EXT_DIR .or. bc(2,1,n) == HOEXTRAP ) then
          j = cslope_lo(2)
          if ( xok(2) ) then
             do i = cslope_lo(1), cslope_hi(1)
                uc_yslope(i,j,n) = -SIXTEEN/FIFTEEN*crse(i,j-1,n)+ HALF*crse(i,j,n) &
                     + TWO3RD*crse(i,j+1,n) - TENTH*crse(i,j+2,n)
             end do
          else
             do i = cslope_lo(1), cslope_hi(1)
                uc_yslope(i,j,n) = &
                     FOURTH * (crse(i,j+1,n) + FIVE*crse(i,j,n) - SIX*crse(i,j-1,n) )
             end do
          end if
          do i = cslope_lo(1), cslope_hi(1)
             lc_yslope(i,j,n) = uclc_slope(uc_yslope(i,j,n),crse,crse_lo,i,j,n,dim=2)
          end do
       end if

       if ( bc(2,2,n)  ==  EXT_DIR .or. bc(2,2,n) == HOEXTRAP ) then
          j = cslope_hi(2)
          if ( xok(2) ) then
             do i = cslope_lo(1), cslope_hi(1)
                uc_yslope(i,j,n) = SIXTEEN/FIFTEEN*crse(i,j+1,n)- HALF*crse(i,j,n) &
                     - TWO3RD*crse(i,j-1,n) + TENTH*crse(i,j-2,n)
             end do
          else
             do i = cslope_lo(1), cslope_hi(1)
                uc_yslope(i,j,n) = &
                     -FOURTH * (crse(i,j-1,n) + FIVE*crse(i,j,n) - SIX*crse(i,j+1,n) )
             end do
          end if
          do i = cslope_lo(1), cslope_hi(1)
             lc_yslope(i,j,n) = uclc_slope(uc_yslope(i,j,n),crse,crse_lo,i,j,n,dim=2)
          end do
       end if

    end do

    if ( lim_slope ) then

       if ( lin_limit ) then

          ! compute linear limited slopes
          ! Note that the limited and the unlimited slopes
          ! have the same sign, and it is assumed that they do.

          ! compute slope factors

          xslope_factor = ONE
          yslope_factor = ONE

          do n = 1, size(fine,3)
             where( uc_xslope(:,:,n) /= 0 )
                xslope_factor = min(xslope_factor,lc_xslope(:,:,n)/uc_xslope(:,:,n),ONE)
             end where
             where( uc_yslope(:,:,n) /= 0 )
                yslope_factor = min(yslope_factor,lc_yslope(:,:,n)/uc_yslope(:,:,n),ONE)
             end where
          end do

          ! compute linear limited slopes

          do n = 1, size(fine,3)
             lc_xslope(:,:,n) = xslope_factor*uc_xslope(:,:,n)
             lc_yslope(:,:,n) = yslope_factor*uc_yslope(:,:,n)
          end do

       else

          ! Limit slopes so as to not introduce new maxs or mins.

          do n = 1, size(fine,3)
             do j = fine_lo(2), fine_lo(2)+size(fine,2)-1

                jc = IX_PROJ(j,lratio(2))

                do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
                   ic = IX_PROJ(i,lratio(1))

                   orig_corr_fact = voffx(i)*lc_xslope(ic,jc,n)+ voffy(j)*lc_yslope(ic,jc,n)
                   fine(i,j,n) = crse(ic,jc,n) + orig_corr_fact
                   if ( fine(i,j,n)  >  cmax(ic,jc,n) ) then
                      if ( abs(orig_corr_fact)  >  1.e-10_dp_t*abs(crse(ic,jc,n)) ) then
                         corr_fact = (cmax(ic,jc,n) - crse(ic,jc,n)) / orig_corr_fact
                         alpha(ic,jc,n) = min(alpha(ic,jc,n),corr_fact)
                      end if
                   end if
                   if ( fine(i,j,n)  <  cmin(ic,jc,n) ) then
                      if ( abs(orig_corr_fact)  >  1.e-10_dp_t*abs(crse(ic,jc,n)) ) then
                         corr_fact = (cmin(ic,jc,n) - crse(ic,jc,n)) / orig_corr_fact
                         alpha(ic,jc,n) = min(alpha(ic,jc,n),corr_fact)
                      end if
                   end if

                end do
             end do
          end do

       end if

       ! Do the interpolation with limited slopes.

       do n = 1, size(fine,3)
          do j = fine_lo(2), fine_lo(2)+size(fine,2)-1
             jc = IX_PROJ(j,lratio(2))

             do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
                ic = IX_PROJ(i,lratio(1))

                fine(i,j,n) = crse(ic,jc,n) + alpha(ic,jc,n)*( &
                     + voffx(i)*lc_xslope(ic,jc,n) &
                     + voffy(j)*lc_yslope(ic,jc,n) &
                     )
             end do
          end do
       end do

    else

       ! Do the interpolation using unlimited slopes.

       do n = 1, size(fine,3)
          do j = fine_lo(2), fine_lo(2)+size(fine,2)-1
             jc = IX_PROJ(j,lratio(2))
             do i = fine_lo(1), fine_lo(1)+size(fine,1)-1
                ic = IX_PROJ(i,lratio(1))
                fine(i,j,n) = &
                     crse(ic,jc,n) + voffx(i)*uc_xslope(ic,jc,n)+ voffy(j)*uc_yslope(ic,jc,n)
             end do
          end do
       end do
    end if

  contains

    function uclc_slope(uslope, crse, crse_lo, i, j, n, dim) result(lc)

      integer, intent(in) :: crse_lo(:)
      real(kind = dp_t) :: lc
      real(kind=dp_t), intent(in) :: uslope
      real(kind=dp_t), intent(in)  :: crse(crse_lo(1):,crse_lo(2):,:)
      real(kind=dp_t) :: cen, forw, back, slp
      integer, intent(in) :: i, j, n, dim
      cen  = uslope
      forw = TWO
      back = TWO
      if ( dim == 1 ) then
         forw = forw*(crse(i+1,j,n)-crse(i,j,n))
         back = back*(crse(i,j,n)-crse(i-1,j,n))
      else if ( dim == 2 ) then
         forw = forw*(crse(i,j+1,n)-crse(i,j,n))
         back = back*(crse(i,j,n)-crse(i,j-1,n))
      end if
      slp  = min(abs(forw),abs(back))
      if ( forw*back  <  ZERO ) then
         slp = ZERO
      end if
      lc = sign(ONE,cen)*min(slp,abs(cen))
    end function uclc_slope

  end subroutine lin_cc_interp_2d

  !! linccinterp:   linear conservative interpolation from coarse grid to

  subroutine lin_cc_interp_3d (fine, fine_lo, crse, crse_lo, &
                               lratio, bc, &
                               fvcx, fvcx_lo, fvcy, fvcy_lo, fvcz, fvcz_lo, &
                               cvcx, cvcx_lo, cvcy, cvcy_lo, cvcz, cvcz_lo, &
                               cslope_lo, cslope_hi, lim_slope, lin_limit)

    integer, intent(in) :: fine_lo(:),crse_lo(:)
    integer, intent(in) :: cslope_lo(:),cslope_hi(:)
    integer, intent(in) :: lratio(:)
    integer, intent(in) :: bc(:,:,:)
    integer, intent(in) :: fvcx_lo,fvcy_lo,fvcz_lo,cvcx_lo,cvcy_lo,cvcz_lo
    REAL(kind=dp_t), intent(out) :: fine(fine_lo(1):,fine_lo(2):,fine_lo(3):,:)
    REAL(kind=dp_t), intent(inout) :: crse(crse_lo(1):,crse_lo(2):,crse_lo(3):,:)
    REAL(kind=dp_t), intent(in) :: fvcx(fvcx_lo:)
    REAL(kind=dp_t), intent(in) :: fvcy(fvcy_lo:)
    REAL(kind=dp_t), intent(in) :: fvcz(fvcz_lo:)
    REAL(kind=dp_t), intent(in) :: cvcx(cvcx_lo:)
    REAL(kind=dp_t), intent(in) :: cvcy(cvcy_lo:)
    REAL(kind=dp_t), intent(in) :: cvcz(cvcz_lo:)
    logical        , intent(in) :: lim_slope, lin_limit

    REAL(kind=dp_t) :: voffx(fvcx_lo:fvcx_lo+size(fine,1)-1)
    REAL(kind=dp_t) :: voffy(fvcy_lo:fvcy_lo+size(fine,2)-1)
    REAL(kind=dp_t) :: voffz(fvcz_lo:fvcz_lo+size(fine,3)-1)

    integer :: n, i, ic, j, jc, k, kc, ioff, joff, koff
    REAL(kind=dp_t) :: fxcen, cxcen, fycen, cycen, fzcen, czcen
    REAL(kind=dp_t) :: corr_fact,orig_corr_fact
    logical :: xok(3)
    integer :: nxc(3)

    REAL(kind=dp_t), allocatable ::     uc_xslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::     lc_xslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::  slope_factor(:,:,:)
    REAL(kind=dp_t), allocatable ::     uc_yslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::     lc_yslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::     uc_zslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::     lc_zslope(:,:,:,:)
    REAL(kind=dp_t), allocatable ::         alpha(:,:,:,:)
    REAL(kind=dp_t), allocatable ::          cmax(:,:,:)
    REAL(kind=dp_t), allocatable ::          cmin(:,:,:)

    allocate(     uc_xslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))
    allocate(     lc_xslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))
    allocate(     uc_yslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))
    allocate(     lc_yslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))
    allocate(     uc_zslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))
    allocate(     lc_zslope(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
                            cslope_lo(3):cslope_hi(3),size(fine,4)))

    forall(i = 1:3) nxc(i) = size(crse,dim=i) - 2
    xok = (nxc >=  2)

    do k = fvcz_lo, fvcz_lo+size(fine,3)-1
       kc = IX_PROJ(k,lratio(3))
       fzcen = HALF*(fvcz(k)+fvcz(k+1))
       czcen = HALF*(cvcz(kc)+cvcz(kc+1))
       voffz(k) = (fzcen-czcen)/(cvcz(kc+1)-cvcz(kc))
    end do
    do j = fvcy_lo, fvcy_lo+size(fine,2)-1
       jc = IX_PROJ(j,lratio(2))
       fycen = HALF*(fvcy(j)+fvcy(j+1))
       cycen = HALF*(cvcy(jc)+cvcy(jc+1))
       voffy(j) = (fycen-cycen)/(cvcy(jc+1)-cvcy(jc))
    end do
    do i = fvcx_lo, fvcx_lo+size(fine,1)-1
       ic = IX_PROJ(i,lratio(1))
       fxcen = HALF*(fvcx(i)+fvcx(i+1))
       cxcen = HALF*(cvcx(ic)+cvcx(ic+1))
       voffx(i) = (fxcen-cxcen)/(cvcx(ic+1)-cvcx(ic))
    end do
    !
    ! Prevent underflow for small crse values.
    !
    where(abs(crse) < 1.e-20_dp_t) crse = ZERO
    !
    ! Computed unlimited and limited slopes
    !
    do n = 1, size(crse,4)

       do k = cslope_lo(3),cslope_hi(3)
          do j = cslope_lo(2),cslope_hi(2)
             do i = cslope_lo(1),cslope_hi(1)
                uc_xslope(i,j,k,n) = HALF*(crse(i+1,j,k,n)-crse(i-1,j,k,n))
                lc_xslope(i,j,k,n) = &
                     uclc_slope(uc_xslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=1)
             end do
          end do
       end do

       if ( bc(1,1,n)  ==  EXT_DIR .or. bc(1,1,n) == HOEXTRAP ) then
          i = cslope_lo(1)
          if ( xok(1) ) then
             do k = cslope_lo(3),cslope_hi(3)
                do j = cslope_lo(2),cslope_hi(2)
                   uc_xslope(i,j,k,n) = -SIXTEEN/FIFTEEN*crse(i-1,j,k,n) &
                        + HALF*crse(i,j,k,n)+ TWO3RD*crse(i+1,j,k,n) - TENTH*crse(i+2,j,k,n)
                end do
             end do
          else
             do k = cslope_lo(3),cslope_hi(3)
                do j = cslope_lo(2),cslope_hi(2)
                   uc_xslope(i,j,k,n) = &
                        FOURTH * (crse(i+1,j,k,n) + FIVE*crse(i,j,k,n) - SIX*crse(i-1,j,k,n))
                end do
             end do
          end if
          do k = cslope_lo(3),cslope_hi(3)
             do j = cslope_lo(2),cslope_hi(2)
                lc_xslope(i,j,k,n) = &
                     uclc_slope(uc_xslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=1)
             end do
          end do
       end if

       if ( bc(1,2,n)  ==  EXT_DIR .or. bc(1,2,n) == HOEXTRAP ) then
          i = cslope_hi(1)
          if ( xok(1) ) then
             do k = cslope_lo(3),cslope_hi(3)
                do j = cslope_lo(2),cslope_hi(2)
                   uc_xslope(i,j,k,n) = SIXTEEN/FIFTEEN*crse(i+1,j,k,n) &
                        - HALF*crse(i,j,k,n)- TWO3RD*crse(i-1,j,k,n) + TENTH*crse(i-2,j,k,n)
                end do
             end do
          else
             do k = cslope_lo(3),cslope_hi(3)
                do j = cslope_lo(2),cslope_hi(2)
                   uc_xslope(i,j,k,n) = -FOURTH * (crse(i-1,j,k,n) &
                        + FIVE*crse(i,j,k,n) - SIX*crse(i+1,j,k,n) )
                end do
             end do
          end if
          do k = cslope_lo(3),cslope_hi(3)
             do j = cslope_lo(2),cslope_hi(2)
                lc_xslope(i,j,k,n) = &
                     uclc_slope(uc_xslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=1)
             end do
          end do
       end if

       do k = cslope_lo(3),cslope_hi(3)
          do j = cslope_lo(2),cslope_hi(2)
             do i = cslope_lo(1),cslope_hi(1)
                uc_yslope(i,j,k,n) = HALF*(crse(i,j+1,k,n)-crse(i,j-1,k,n))
                lc_yslope(i,j,k,n) = &
                     uclc_slope(uc_yslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=2)
             end do
          end do
       end do

       if ( bc(2,1,n)  ==  EXT_DIR .or. bc(2,1,n) == HOEXTRAP ) then
          j = cslope_lo(2)
          if ( xok(2) ) then
             do k = cslope_lo(3),cslope_hi(3)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_yslope(i,j,k,n) = -SIXTEEN/FIFTEEN*crse(i,j-1,k,n) &
                        + HALF*crse(i,j,k,n)+ TWO3RD*crse(i,j+1,k,n) - TENTH*crse(i,j+2,k,n)
                end do
             end do
          else
             do k = cslope_lo(3),cslope_hi(3)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_yslope(i,j,k,n) = &
                        FOURTH * (crse(i,j+1,k,n) + FIVE*crse(i,j,k,n) - SIX*crse(i,j-1,k,n))
                end do
             end do
          end if
          do k = cslope_lo(3),cslope_hi(3)
             do i = cslope_lo(1),cslope_hi(1)
                lc_yslope(i,j,k,n) = &
                     uclc_slope(uc_yslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=2)
             end do
          end do
       end if

       if ( bc(2,2,n)  ==  EXT_DIR .or. bc(2,2,n) == HOEXTRAP ) then
          j = cslope_hi(2)
          if ( xok(2) ) then
             do k = cslope_lo(3),cslope_hi(3)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_yslope(i,j,k,n) = SIXTEEN/FIFTEEN*crse(i,j+1,k,n) &
                        - HALF*crse(i,j,k,n)- TWO3RD*crse(i,j-1,k,n) + TENTH*crse(i,j-2,k,n)
                end do
             end do
          else
             do k = cslope_lo(3),cslope_hi(3)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_yslope(i,j,k,n) = -FOURTH * (crse(i,j-1,k,n) &
                        + FIVE*crse(i,j,k,n) - SIX*crse(i,j+1,k,n) )
                end do
             end do
          end if
          do k = cslope_lo(3),cslope_hi(3)
             do i = cslope_lo(1),cslope_hi(1)
                lc_yslope(i,j,k,n) = &
                     uclc_slope(uc_yslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=2)
             end do
          end do
       end if

       do k = cslope_lo(3),cslope_hi(3)
          do j = cslope_lo(2),cslope_hi(2)
             do i = cslope_lo(1),cslope_hi(1)
                uc_zslope(i,j,k,n) = HALF*(crse(i,j,k+1,n)-crse(i,j,k-1,n))
                lc_zslope(i,j,k,n) = &
                     uclc_slope(uc_zslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=3)
             end do
          end do
       end do

       if ( bc(3,1,n)  == EXT_DIR .or. bc(3,1,n) == HOEXTRAP ) then
          k = cslope_lo(3)
          if ( xok(3) ) then
             do j = cslope_lo(2),cslope_hi(2)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_zslope(i,j,k,n) = -SIXTEEN/FIFTEEN*crse(i,j,k-1,n) &
                        + HALF*crse(i,j,k,n)+ TWO3RD*crse(i,j,k+1,n) - TENTH*crse(i,j,k+2,n)
                end do
             end do
          else
             do j = cslope_lo(2),cslope_hi(2)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_zslope(i,j,k,n) = &
                        FOURTH * (crse(i,j,k+1,n) + FIVE*crse(i,j,k,n) - SIX*crse(i,j,k-1,n))
                end do
             end do
          end if
          do j = cslope_lo(2),cslope_hi(2)
             do i = cslope_lo(1),cslope_hi(1)
                lc_zslope(i,j,k,n) = &
                     uclc_slope(uc_zslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=3)
             end do
          end do
       end if

       if ( bc(3,2,n)  ==  EXT_DIR .or. bc(3,2,n)  ==  HOEXTRAP ) then
          k = cslope_hi(3)
          if ( xok(3) ) then
             do j = cslope_lo(2),cslope_hi(2)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_zslope(i,j,k,n) = SIXTEEN/FIFTEEN*crse(i,j,k+1,n) &
                        - HALF*crse(i,j,k,n)- TWO3RD*crse(i,j,k-1,n) + TENTH*crse(i,j,k-2,n)
                end do
             end do
          else
             do j = cslope_lo(2),cslope_hi(2)
                do i = cslope_lo(1),cslope_hi(1)
                   uc_zslope(i,j,k,n) = -FOURTH * (crse(i,j,k-1,n) &
                        + FIVE*crse(i,j,k,n) - SIX*crse(i,j,k+1,n) )
                end do
             end do
          end if
          do j = cslope_lo(2),cslope_hi(2)
             do i = cslope_lo(1),cslope_hi(1)
                lc_zslope(i,j,k,n) = &
                     uclc_slope(uc_zslope(i,j,k,n),crse,crse_lo,i,j,k,n,dim=3)
             end do
          end do
       end if

    end do

    if ( lim_slope ) then

       allocate(alpha(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
            cslope_lo(3):cslope_hi(3),size(fine,4)))

       alpha = ONE

       if ( lin_limit ) then

          ! compute linear limited slopes
          ! Note that the limited and the unlimited slopes
          ! have the same sign, and it is assumed that they do.
          !
          allocate( slope_factor(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
               cslope_lo(3):cslope_hi(3)) )
          !
          ! x slopes
          !
          slope_factor = ONE
          do n = 1, size(crse,4)
             where( uc_xslope(:,:,:,n) /= 0 )
                slope_factor = min(slope_factor,lc_xslope(:,:,:,n)/uc_xslope(:,:,:,n),ONE)
             end where
          end do
          do n = 1, size(crse,4)
             lc_xslope(:,:,:,n) = slope_factor*uc_xslope(:,:,:,n)
          end do
          !
          ! y slopes
          !
          slope_factor = ONE
          do n = 1, size(crse,4)
             where( uc_yslope(:,:,:,n) /= 0 )
                slope_factor = min(slope_factor,lc_yslope(:,:,:,n)/uc_yslope(:,:,:,n),ONE)
             end where
          end do
          do n = 1, size(crse,4)
             lc_yslope(:,:,:,n) = slope_factor*uc_yslope(:,:,:,n)
          end do
          !
          ! z slopes
          !
          slope_factor = ONE
          do n = 1, size(crse,4)
             where( uc_zslope(:,:,:,n) /= 0 )
                slope_factor = min(slope_factor,lc_zslope(:,:,:,n)/uc_zslope(:,:,:,n),ONE)
             end where
          end do
          do n = 1, size(crse,4)
             lc_zslope(:,:,:,n) = slope_factor*uc_zslope(:,:,:,n)
          end do

          deallocate(slope_factor)

       else

          allocate( cmax(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
               cslope_lo(3):cslope_hi(3)) )
          allocate( cmin(cslope_lo(1):cslope_hi(1),cslope_lo(2):cslope_hi(2), &
               cslope_lo(3):cslope_hi(3)) )

          do n = 1, size(crse,4)
             !
             ! Define cmax and cmin as neighborhood max/mins.
             !
             do k = cslope_lo(3),cslope_hi(3)
                do j = cslope_lo(2),cslope_hi(2)
                   do i = cslope_lo(1),cslope_hi(1)
                      cmax(i,j,k) = crse(i,j,k,n)
                      cmin(i,j,k) = crse(i,j,k,n)
                      do koff = -1,1
                         do joff = -1,1
                            do ioff = -1,1
                               cmax(i,j,k) = max(cmax(i,j,k),crse(i+ioff,j+joff,k+koff,n))
                               cmin(i,j,k) = min(cmin(i,j,k),crse(i+ioff,j+joff,k+koff,n))
                            end do
                         end do
                      end do
                   end do
                end do
             end do
             !
             ! Limit slopes so as to not introduce new maxs or mins.
             !
             do k = fine_lo(3), fine_lo(3)+size(fine, 3) - 1
                kc = IX_PROJ(k,lratio(3))
                do j = fine_lo(2), fine_lo(2)+size(fine, 2) - 1
                   jc = IX_PROJ(j,lratio(2))
                   do i = fine_lo(1), fine_lo(1)+size(fine, 1) - 1
                      ic = IX_PROJ(i,lratio(1))
                      orig_corr_fact = &
                           + voffx(i)*lc_xslope(ic,jc,kc,n) &
                           + voffy(j)*lc_yslope(ic,jc,kc,n) &
                           + voffz(k)*lc_zslope(ic,jc,kc,n)
                      fine(i,j,k,n) = crse(ic,jc,kc,n) + orig_corr_fact
                      if ( fine(i,j,k,n) > cmax(ic,jc,kc) ) then
                         if ( abs(orig_corr_fact) > 1.e-10_dp_t*abs(crse(ic,jc,kc,n)) ) then
                            corr_fact = (cmax(ic,jc,kc) - crse(ic,jc,kc,n)) / orig_corr_fact
                            alpha(ic,jc,kc,n) = min(alpha(ic,jc,kc,n),corr_fact)
                         end if
                      end if
                      if ( fine(i,j,k,n)  <  cmin(ic,jc,kc) ) then
                         if ( abs(orig_corr_fact)  >  1.e-10_dp_t*abs(crse(ic,jc,kc,n)) ) then
                            corr_fact = (cmin(ic,jc,kc) - crse(ic,jc,kc,n)) / orig_corr_fact
                            alpha(ic,jc,kc,n) = min(alpha(ic,jc,kc,n),corr_fact)
                         end if
                      end if
                   end do
                end do
             end do
          end do

          deallocate(cmax,cmin)
       end if
       !
       ! Do the interpolation with limited slopes.
       !
       do n = 1, size(crse,4)
          do k = fine_lo(3), fine_lo(3)+size(fine, 3) - 1
             kc = IX_PROJ(k,lratio(3))
             do j = fine_lo(2), fine_lo(2)+size(fine, 2) - 1
                jc = IX_PROJ(j,lratio(2))
                do i = fine_lo(1), fine_lo(1)+size(fine, 1) - 1
                   ic = IX_PROJ(i,lratio(1))
                   fine(i,j,k,n) = crse(ic,jc,kc,n) &
                        + alpha(ic,jc,kc,n) * &
                        ( &
                        + voffx(i)*lc_xslope(ic,jc,kc,n)&
                        + voffy(j)*lc_yslope(ic,jc,kc,n)&
                        + voffz(k)*lc_zslope(ic,jc,kc,n)&
                        )
                end do
             end do
          end do
       end do

       deallocate(alpha)

    else
       !
       ! Do the interpolation using unlimited slopes.
       !
       do n = 1, size(crse,4)
          do k = fine_lo(3), fine_lo(3)+size(fine,3) - 1
             kc = IX_PROJ(k,lratio(3))
             do j = fine_lo(2), fine_lo(2)+size(fine, 2) - 1
                jc = IX_PROJ(j,lratio(2))
                do i = fine_lo(1), fine_lo(1)+size(fine,1) - 1
                   ic = IX_PROJ(i,lratio(1))
                   fine(i,j,k,n) = crse(ic,jc,kc,n) &
                        + voffx(i)*uc_xslope(ic,jc,kc,n) &
                        + voffy(j)*uc_yslope(ic,jc,kc,n) &
                        + voffz(k)*uc_zslope(ic,jc,kc,n)
                end do
             end do
          end do
       end do

    end if

    deallocate(uc_xslope,lc_xslope)
    deallocate(uc_yslope,lc_yslope)
    deallocate(uc_zslope,lc_zslope)

  contains

    function uclc_slope(uslope, crse, crse_lo, i, j, k, n, dim) result(lc)
      integer, intent(in) :: crse_lo(:)
      real(kind = dp_t) :: lc
      real(kind=dp_t), intent(in) :: uslope
      real(kind=dp_t), intent(in)  :: crse(crse_lo(1):,crse_lo(2):,crse_lo(3):,:)
      real(kind=dp_t) :: cen, forw, back, slp
      integer, intent(in) :: i, j, k, n, dim
      cen  = uslope
      forw = TWO
      back = TWO
      if ( dim == 1 ) then
         forw = forw*(crse(i+1,j,k,n)-crse(i,j,k,n))
         back = back*(crse(i,j,k,n)-crse(i-1,j,k,n))
      else if ( dim == 2 ) then
         forw = forw*(crse(i,j+1,k,n)-crse(i,j,k,n))
         back = back*(crse(i,j,k,n)-crse(i,j-1,k,n))
      else if ( dim == 3 ) then
         forw = forw*(crse(i,j,k+1,n)-crse(i,j,k,n))
         back = back*(crse(i,j,k,n)-crse(i,j,k-1,n))
      end if
      slp  = min(abs(forw),abs(back))
      if ( forw*back  <  ZERO ) then
         slp = ZERO
      end if
      lc = sign(ONE,cen)*min(slp,abs(cen))
    end function uclc_slope

  end subroutine lin_cc_interp_3d

  !! fourth_order_interp:   fourth order unlimited interpolation from coarse grid to fine
  !!                    :   NOTE: this is not necessarily conservative!

  subroutine fourth_order_interp_2d (fine, fine_lo, crse, crse_lo, lratio, &
       cg_lo, cg_hi)

    use fourth_order_interp_coef_module

    implicit none

    integer, intent(in) :: fine_lo(:), crse_lo(:), cg_lo(:), cg_hi(:)
    integer, intent(in) :: lratio(:)
    real(kind=dp_t), intent(  out) :: fine(fine_lo(1):,fine_lo(2):,:)
    real(kind=dp_t), intent(inout) :: crse(crse_lo(1):,crse_lo(2):,:)

    real(kind=dp_t) :: b(21), A2T(size(A2,2),0:size(A2,1)-1), c(15)

    integer :: n, i, j, ic, jc, k
    integer :: fine_hi(2)

    fine_hi(1) = fine_lo(1) + size(fine,1) - 1
    fine_hi(2) = fine_lo(2) + size(fine,2) - 1

    !
    ! Prevent underflow for small crse values.
    !
    where ( abs(crse) <= 1.0e-20_dp_t ) crse = ZERO
    !
    ! Use A2T instead of A2 for more efficient memory access.
    !
    A2T = Transpose(A2)
    !
    ! Do interpolation.  For this method of interpolation, it is more
    ! efficient to loop over the coarse cells than the fine cells
    ! since the b and c vectors depend on the coarse cell, not on the
    ! fine cell.
    !
    do n = 1, size(fine,3)
       do jc = cg_lo(2), cg_hi(2)
          do ic = cg_lo(1), cg_hi(1)
             b(  1) = crse(ic-2, jc-1, n)
             b(  2) = crse(ic-2, jc+0, n)
             b(  3) = crse(ic-2, jc+1, n)
             b(  4) = crse(ic-1, jc-2, n)
             b(  5) = crse(ic-1, jc-1, n)
             b(  6) = crse(ic-1, jc+0, n)
             b(  7) = crse(ic-1, jc+1, n)
             b(  8) = crse(ic-1, jc+2, n)
             b(  9) = crse(ic+0, jc-2, n)
             b( 10) = crse(ic+0, jc-1, n)
             b( 11) = crse(ic+0, jc+1, n)
             b( 12) = crse(ic+0, jc+2, n)
             b( 13) = crse(ic+1, jc-2, n)
             b( 14) = crse(ic+1, jc-1, n)
             b( 15) = crse(ic+1, jc+0, n)
             b( 16) = crse(ic+1, jc+1, n)
             b( 17) = crse(ic+1, jc+2, n)
             b( 18) = crse(ic+2, jc-1, n)
             b( 19) = crse(ic+2, jc+0, n)
             b( 20) = crse(ic+2, jc+1, n)
             b( 21) = 1000.0_dp_t*crse(ic+0, jc+0, n)

             c = matmul(P2, b)

             do j = jc*lratio(2),(jc+1)*lratio(2)-1
                do i = ic*lratio(1),(ic+1)*lratio(1)-1

                   k = 2*(i-ic*lratio(1)) + (j-jc*lratio(2))

                   if (i.ge.fine_lo(1) .and. i.le.fine_hi(1) .and. &
                       j.ge.fine_lo(2) .and. j.le.fine_hi(2)) &
                   fine(i,j,n) = dot_product(c, A2T(:,k))*4

                end do
             end do

          end do
       end do
    end do

  end subroutine fourth_order_interp_2d

  subroutine pclin_face_interp_2d(dir, lo, hi, fine, flo, crse, clo, r)
    use box_module, only : int_coarsen, int_coarsen_pair
    use bl_error_module
    integer, intent(in) :: dir, lo(2), hi(2), flo(2), clo(2), r
    real(kind=dp_t), intent(in   ) :: crse(clo(1):,clo(2):)
    real(kind=dp_t), intent(inout) :: fine(flo(1):,flo(2):)

    integer :: i,j, ic, jc, icp(2), jcp(2)

    if (r.eq.2) then
       if (dir .eq. 1) then
          do j = lo(2), hi(2)
             jc = int_coarsen(j,2)
             do i = lo(1), hi(1)
                icp = int_coarsen_pair(i,2)
                fine(i,j) = HALF*(crse(icp(1),jc) + crse(icp(2),jc))
             end do
          end do
       else
          do j = lo(2), hi(2)
             jcp = int_coarsen_pair(j,2)
             do i = lo(1), hi(1)
                ic = int_coarsen(i,2)
                fine(i,j) = HALF*(crse(ic,jcp(1)) + crse(ic,jcp(2)))
             end do
          end do
       end if
    else
       call bl_error("pclin_face_interp_2d: ref ratio != 2 not implemented")
    end if

  end subroutine pclin_face_interp_2d

  subroutine pclin_face_interp_3d(dir, lo, hi, fine, flo, crse, clo, r)
    use box_module, only : int_coarsen, int_coarsen_pair
    use bl_error_module
    integer, intent(in) :: dir, lo(3), hi(3), flo(3), clo(3), r
    real(kind=dp_t), intent(in   ) :: crse(clo(1):,clo(2):,clo(3):)
    real(kind=dp_t), intent(inout) :: fine(flo(1):,flo(2):,flo(3):)

    integer :: i,j,k, ic, jc, kc, icp(2), jcp(2), kcp(2)

    if (r.eq.2) then
       if (dir .eq. 1) then
          do k = lo(3), hi(3)
             kc = int_coarsen(k,2)
             do j = lo(2), hi(2)
                jc = int_coarsen(j,2)
                do i = lo(1), hi(1)
                   icp = int_coarsen_pair(i,2)
                   fine(i,j,k) = HALF*(crse(icp(1),jc,kc)+crse(icp(2),jc,kc))
                end do
             end do
          end do
       else if (dir .eq. 2) then
          do k = lo(3), hi(3)
             kc = int_coarsen(k,2)
             do j = lo(2), hi(2)
                jcp = int_coarsen_pair(j,2)
                do i = lo(1), hi(1)
                   ic = int_coarsen(i,2)
                   fine(i,j,k) = HALF*(crse(ic,jcp(1),kc)+crse(ic,jcp(2),kc))
                end do
             end do
          end do
       else
          do k = lo(3), hi(3)
             kcp = int_coarsen_pair(k,2)
             do j = lo(2), hi(2)
                jc = int_coarsen(j,2)
                do i = lo(1), hi(1)
                   ic = int_coarsen(i,2)
                   fine(i,j,k) = HALF*(crse(ic,jc,kcp(1))+crse(ic,jc,kcp(2)))
                end do
             end do
          end do
       end if
    else
       call bl_error("pclin_face_interp_3d: ref ratio != 2 not implemented")
    end if

  end subroutine pclin_face_interp_3d

end module interp_module


!======================================================================
  PROGRAM sphf
!======================================================================
!
!  This program computes the radial functions for simple Hartree-Fock
!  cases.
!
!   SUBROUTINE called:
!       open_files (in hf_inout.f90)
!       read_hf_param
!       get_case
!       define_spline
!       get_estimates
!       refine_grid
!       write_spline_param  (in get_spline_param.fi90)
!       solve_HF_equations  (in solve_scf.f90 and solve_all.f90
!       write_hf_param ( in read_hf_param.f90)
!
!   Written by:  by Charlotte  Froese Fischer
!   Date:        April, 2010
!
!----------------------------------------------------------------------
!
     USE hf_inout
     USE hf_param
     IMPLICIT NONE

     CALL open_files

     ! .. read parameters (optional)
     CALL read_hf_param

     ! .. get data about the problem to be solved and how the spline
     ! .. calculation is to be performed, including the grid points
     CALL get_case

     ! .. Initialize the basic B-spline environment and
     ! .. evaluate spline matrix elements for typical operators in
     ! .. in non-relativistic atomic structure theory using the
     ! .. spline-galerkin method
     CALL define_spline

     ! Solve for good and then excellent accuracy
     Do acc = 1, acc_max
        If (acc == 1) then
           Call get_estimates
        Else
           Call Refine_grid
        End if
        Call write_spline_param
        Call solve_HF_equations

     End DO

     Call write_hf_param        ! for rerunning the highest level

  END PROGRAM sphf