!*****************************************************************************************
!> author: Jacob Williams
!  license: BSD
!
!  Numerical differentiation of a 1D function `f(x)` using Neville's process.
!
!## Authors
!   * J. Oliver, "An algorithm for numerical differentiation of a function
!     of one real variable", Journal of Computational and Applied Mathematics
!     6 (2) (1980) 145–160. [Algol 60 source in original paper]
!   * David Kahaner, Fortran 77 code from
!     [NIST](ftp://math.nist.gov/pub/repository/diff/src/DIFF)
!   * Jacob Williams : 2/17/2013 : Converted to modern Fortran.
!     Some refactoring, addition of test cases.

    module diff_module

    use numdiff_kinds_module

    implicit none

    private

    type,public :: diff_func
        !! class to define the function for [[diff]]
        private
        logical :: stop = .false.
        procedure(func),pointer :: f => null()
        contains
        private
        procedure :: faccur
        procedure,public :: set_function
        procedure,public :: compute_derivative => diff
        procedure,public :: terminate
    end type diff_func

    abstract interface
        function func(me,x) result(fx)
            !! interface to function for [[diff]]
            import :: diff_func,wp
            implicit none
            class(diff_func),intent(inout) :: me
            real(wp),intent(in) :: x
            real(wp) :: fx
        end function func
    end interface

    contains
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date:  12/27/2015
!
!  Set the function in a [[diff_func]].
!  Must be called before [[diff]].

    subroutine set_function(me,f)

    implicit none

    class(diff_func),intent(inout) :: me
    procedure(func) :: f

    me%f => f

    end subroutine set_function
!*****************************************************************************************

!*****************************************************************************************
!>
!  Can be called by the user in the function to terminate the computation.
!  This will set `ifail=-1`.

    subroutine terminate(me)

    implicit none

    class(diff_func),intent(inout) :: me

    me%stop = .true.

    end subroutine terminate
!*****************************************************************************************

!*****************************************************************************************
!>
!  the procedure `diff` calculates the first, second or
!  third order derivative of a function by using neville's process to
!  extrapolate from a sequence of simple polynomial approximations based on
!  interpolating points distributed symmetrically about `x0` (or lying only on
!  one side of `x0` should this be necessary).  if the specified tolerance is
!  non-zero then the procedure attempts to satisfy this absolute or relative
!  accuracy requirement, while if it is unsuccessful or if the tolerance is
!  set to zero then the result having the minimum achievable estimated error
!  is returned instead.

    subroutine diff(me,iord,x0,xmin,xmax,eps,accr,deriv,error,ifail)

    implicit none

    class(diff_func),intent(inout) :: me
    integer,intent(in)    :: iord   !! 1, 2 or 3 specifies that the first, second or third order
                                    !! derivative,respectively, is required.
    real(wp), intent(in)  :: x0     !! the point at which the derivative of the function is to be calculated.
    real(wp), intent(in)  :: xmin   !! `xmin`, `xmax` restrict the interpolating points to lie in [`xmin`, `xmax`], which
                                    !! should be the largest interval including `x0` in which the function is
                                    !! calculable and continuous.
    real(wp), intent(in)  :: xmax   !! `xmin`, `xmax` restrict the interpolating points to lie in [`xmin`, `xmax`], which
                                    !! should be the largest interval including `x0` in which the function is
                                    !! calculable and continuous.
    real(wp), intent(in)  :: eps    !! denotes the tolerance, either absolute or relative. `eps=0` specifies that
                                    !! the error is to be minimised, while `eps>0` or `eps<0` specifies that the
                                    !! absolute or relative error, respectively, must not exceed `abs(eps)` if
                                    !! possible.  the accuracy requirement should not be made stricter than
                                    !! necessary, since the amount of computation tends to increase as
                                    !! the magnitude of `eps` decreases, and is particularly high when `eps=0`.
    real(wp), intent(in)  :: accr   !! denotes that the absolute (`accr>0`) or relative (`accr<0`) errors in the
                                    !! computed values of the function are most unlikely to exceed `abs(accr)`, which
                                    !! should be as small as possible.  if the user cannot estimate `accr` with
                                    !! complete confidence, then it should be set to zero.
    real(wp), intent(out) :: deriv  !! the calculated value of the derivative
    real(wp), intent(out) :: error  !! an estimated upper bound on the magnitude of the absolute error in
                                    !! the calculated result.  it should always be examined, since in extreme case
                                    !! may indicate that there are no correct significant digits in the value
                                    !! returned for derivative.
    integer, intent(out)  :: ifail  !! will have one of the following values on exit:
                                    !!  *0* the procedure was successful.
                                    !!  *1* the estimated error in the result exceeds the (non-zero) requested
                                    !!      error, but the most accurate result possible has been returned.
                                    !!  *2* input data incorrect (derivative and error will be undefined).
                                    !!  *3* the interval [`xmin`, `xmax`] is too small (derivative and error will be
                                    !!      undefined).
                                    !!  *-1* stopped by the user.

    real(wp) :: acc,beta,beta4,h,h0,h1,h2, &
        newh1,newh2,heval,hprev,baseh,hacc1,hacc2,nhacc1, &
        nhacc2,minh,maxh,maxh1,maxh2,tderiv,f0,twof0,f1,f2,f3,f4,fmax, &
        maxfun,pmaxf,df1,deltaf,pdelta,z,zpower,c0f0,c1,c2,c3,dnew,dprev, &
        re,te,newerr,temerr,newacc,pacc1,pacc2,facc1,facc2,acc0, &
        acc1,acc2,relacc,twoinf,twosup,s, &
        d(10),denom(10),e(10),minerr(10),maxf(0:10),save(0:13),storef(-45:45),factor
    integer :: i,j,k,n,nmax,method,signh,fcount,init
    logical :: ignore(10),contin,saved
    real(wp) :: dummy1,dummy2

    integer,parameter :: eta = digits(1.0_wp) - 1       !! minimum number of significant binary digits (apart from the
                                                        !! sign digit) used to represent the mantissa of real(wp) numbers. it should
                                                        !! be decreased by one if the computer truncates rather than rounds.
    integer,parameter :: inf = -minexponent(1.0_wp) - 2 !! the largest possible positive integers subject to
                                                        !! 2**(-inf) and -2**(-inf) being representable real(wp) numbers.
    integer,parameter :: sup = maxexponent(1.0_wp) - 1  !! the largest possible positive integers subject to
                                                        !! 2**sup and -2**sup being representable real(wp) numbers.

    real(wp),parameter :: sqrt2 = sqrt(2.0_wp)  !! \( \sqrt(2) \)
    real(wp),parameter :: sqrt3 = sqrt(3.0_wp)  !! \( \sqrt(3) \)

    me%stop = .false.

    ! execution commences with examination of input parameters
    if (iord<1 .or. iord>3 .or. xmax<=xmin .or. &
        x0>xmax .or. x0<xmin .or. .not. associated(me%f)) then

      ifail = 2

    else

        acc = accr
        twoinf = 2.0_wp**(-inf)
        twosup = 2.0_wp**sup
        factor = 2.0_wp**(real((inf+sup),wp)/30.0_wp)
        if (factor < 256.0_wp)factor=256.0_wp
        maxh1 = xmax - x0
        signh = 1
        if (x0-xmin <= maxh1) then
          maxh2 = x0 - xmin
        else
          maxh2 = maxh1
          maxh1 = x0 - xmin
          signh = -1
        end if
        relacc = 2.0_wp**(1.0_wp-eta)
        maxh1 = (1.0_wp-relacc)*maxh1
        maxh2 = (1.0_wp-relacc)*maxh2
        s=128.0_wp*twoinf
        if (abs(x0) > 128.0_wp*twoinf*2.0_wp**eta) s = abs(x0)*2.0_wp**(-eta)
        if (maxh1 < s) then
          ! interval too small
          ifail =3
          return
        end if
        if (acc < 0.0_wp) then
          if (-acc > relacc) relacc = -acc
          acc = 0.0_wp
        end if

        ! determine the smallest spacing at which the calculated
        ! function values are unequal near x0.

        f0 = me%f(x0)
        if (me%stop) then
          ifail = -1
          return
        end if
        twof0 = f0 + f0
        if (abs(x0) > twoinf*2.0_wp**eta) then
          h = abs(x0)*2.0_wp**(-eta)
          z = 2.0_wp
        else
          h = twoinf
          z = 64.0_wp
        end if
        df1 = me%f(x0+signh*h) - f0
        if (me%stop) then
          ifail = -1
          return
        end if
        do
            if (df1 /= 0.0_wp .or. z*h > maxh1) exit
            h = z*h
            df1 = me%f(x0+signh*h) - f0
            if (me%stop) then
              ifail = -1
              return
            end if
            if (z /= 2.0_wp) then
              if (df1 /= 0.0_wp) then
                h = h/z
                z = 2.0_wp
                df1 = 0.0_wp
              else
                if (z*h > maxh1) z = 2.0_wp
              end if
            end if
        end do

        if (df1 == 0.0_wp) then
        ! constant function
          deriv = 0.0_wp
          error = 0.0_wp
          ifail = 0
          return
        end if
        if (h > maxh1/128.0_wp) then
        ! minimum h too large
          ifail = 3
          return
        end if

        h = 8.0_wp*h
        h1 = signh*h
        h0 = h1
        h2 = -h1
        minh = 2.0_wp**(-min(inf,sup)/iord)
        if (minh < h) minh = h
        select case (iord)
        case(1)
            s = 8.0_wp
        case(2)
            s = 9.0_wp*sqrt3
        case(3)
            s = 27.0_wp
        end select
        if (minh > maxh1/s) then
          ifail = 3
          return
        end if
        if (minh > maxh2/s .or. maxh2 < 128.0_wp*twoinf) then
          method = 1
        else
          method = 2
        end if

        ! method 1 uses 1-sided formulae, and method 2 symmetric.
        ! now estimate accuracy of calculated function values.

        if (method /= 2 .or. iord == 2) then
          if (x0 /= 0.0_wp) then
            dummy1 = 0.0_wp
            dummy2 = -h1
            call me%faccur(dummy1,dummy2,acc0,x0,twoinf,f0,f1,ifail)
            if (ifail==-1) return
          else
            acc0 = 0.0_wp
          end if
        end if

        if (abs(h1) > twosup/128.0_wp) then
          hacc1 = twosup
        else
          hacc1 = 128.0_wp*h1
        end if

        if (abs(hacc1)/4.0_wp < minh) then
          hacc1 = 4.0_wp*signh*minh
        else if (abs(hacc1) > maxh1) then
          hacc1 = signh*maxh1
        end if
        f1 = me%f(x0+hacc1)
        if (me%stop) then
          ifail = -1
          return
        end if
        call me%faccur(hacc1,h1,acc1,x0,twoinf,f0,f1,ifail)
        if (ifail==-1) return
        if (method == 2) then
          hacc2 = -hacc1
          if (abs(hacc2) > maxh2) hacc2 = -signh * maxh2
          f1 = me%f(x0 + hacc2)
          if (me%stop) then
            ifail = -1
            return
          end if
          call me%faccur(hacc2,h2,acc2,x0,twoinf,f0,f1,ifail)
          if (ifail==-1) return
        end if
        nmax = 8
        if (eta > 36) nmax = 10
        n = -1
        fcount = 0
        deriv = 0.0_wp
        error = twosup
        init = 3
        contin = .true.

        do

            n = n+1
            if (.not. contin) exit

            if (init == 3) then
            ! calculate coefficients for differentiation
            ! formulae and neville extrapolation algorithm
              if (iord == 1) then
                beta=2.0_wp
              else if (method == 2) then
                beta = sqrt2
              else
                beta = sqrt3
              end if
              beta4 = beta**4
              z = beta
              if (method == 2) z = z**2
              zpower = 1.0_wp
              do k = 1,nmax
                zpower = z*zpower
                denom(k) = zpower-1
              end do
              if (method == 2 .and. iord == 1) then
                e(1) = 5.0_wp
                e(2) = 6.3_wp
                do i = 3,nmax
                  e(i) = 6.81_wp
                end do
              else if ((method /= 2 .and. iord == 1) .or. &
                       (method == 2 .and. iord == 2)) then
                e(1) = 10.0_wp
                e(2) = 16.0_wp
                e(3) = 20.36_wp
                e(4) = 23.0_wp
                e(5) = 24.46_wp
                do i = 6,nmax
                  e(i) = 26.0_wp
                end do
                if (method == 2 .and. iord == 2) then
                  do i = 1,nmax
                    e(i)=2.0_wp*e(i)
                  end do
                end if
              else if (method /= 2 .and. iord == 2) then
                e(1) = 17.78_wp
                e(2) = 30.06_wp
                e(3) = 39.66_wp
                e(4) = 46.16_wp
                e(5) = 50.26_wp
                do i = 6,nmax
                  e(i) = 55.0_wp
                end do
              else if (method == 2 .and. iord == 3) then
                e(1) = 25.97_wp
                e(2) = 41.22_wp
                e(3) = 50.95_wp
                e(4) = 56.4_wp
                e(5) = 59.3_wp
                do i = 6,nmax
                  e(i) = 62.0_wp
                end do
              else
                e(1) = 24.5_wp
                e(2) = 40.4_wp
                e(3) = 52.78_wp
                e(4) = 61.2_wp
                e(5) = 66.55_wp
                do i = 6,nmax
                  e(i) = 73.0_wp
                end do
                c0f0 = -twof0/(3.0_wp*beta)
                c1 = 3.0_wp/(3.0_wp*beta-1.0_wp)
                c2 = -1.0_wp/(3.0_wp*(beta-1.0_wp))
                c3 = 1.0_wp/(3.0_wp*beta*(5.0_wp-2.0_wp*beta))
              end if
            end if

            if (init >= 2) then
            ! initialization of steplengths, accuracy and other parameters

              heval = signh*minh
              h = heval
              baseh = heval
              maxh = maxh2
              if (method == 1)maxh = maxh1
              do k = 1,nmax
                minerr(k) = twosup
                ignore(k) = .false.
              end do
              if (method == 1) newacc = acc1
              if (method == -1) newacc = acc2
              if (method == 2) newacc = (acc1+acc2)/2.0_wp
              if (newacc < acc) newacc = acc
              if ((method /= 2 .or. iord == 2) .and. newacc < acc0) newacc = acc0
              if (method /= -1) then
                facc1 = acc1
                nhacc1 = hacc1
                newh1 = h1
              end if
              if (method /= 1) then
                facc2 = acc2
                nhacc2 = hacc2
                newh2 = h2
              else
                facc2 = 0.0_wp
                nhacc2 = 0.0_wp
              end if
              init = 1
              j = 0
              saved = .false.
            end if

            ! calculate new or initial function values

            if (init == 1 .and. (n == 0 .or. iord == 1) .and. &
                  .not.(method == 2 .and. fcount >= 45)) then
              if (method == 2) then
                fcount = fcount + 1
                f1 = me%f(x0+heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                storef(fcount) = f1
                f2 = me%f(x0-heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                storef(-fcount) = f2
              else
                j = j+1
                if (j <= fcount) then
                  f1 = storef(j*method)
                else
                  f1 = me%f(x0+heval)
                  if (me%stop) then
                    ifail = -1
                    return
                  end if
                end if
              end if
            else
              f1 = me%f(x0+heval)
              if (me%stop) then
                ifail = -1
                return
              end if
              if (method == 2) then
                f2 = me%f(x0-heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
              end if
            end if
            if (n == 0) then
              if (method == 2 .and. iord == 3) then
                pdelta = f1-f2
                pmaxf = (abs(f1)+abs(f2))/2.0_wp
                heval = beta*heval
                f1 = me%f(x0+heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                f2 = me%f(x0-heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                deltaf = f1-f2
                maxfun = (abs(f1)+abs(f2))/2.0_wp
                heval = beta*heval
                f1 = me%f(x0+heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                f2 = me%f(x0-heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
              else if (method /= 2 .and. iord >= 2) then
                if (iord == 2) then
                  f3 = f1
                else
                  f4 = f1
                  heval = beta*heval
                  f3 = me%f(x0+heval)
                  if (me%stop) then
                    ifail = -1
                    return
                  end if
                end if
                heval = beta*heval
                f2 = me%f(x0+heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
                heval = beta*heval
                f1 = me%f(x0+heval)
                if (me%stop) then
                  ifail = -1
                  return
                end if
              end if
            end if

            ! evaluate a new approximation dnew to the derivative

            if (n > nmax) then
              n = nmax
              do i = 1,n
                maxf(i-1) = maxf(i)
              end do
            end if
            if (method == 2) then
              maxf(n) = (abs(f1)+abs(f2))/2.0_wp
              if (iord == 1) then
                dnew = (f1-f2)/2.0_wp
              else if (iord == 2) then
                dnew = f1+f2-twof0
              else
                dnew = -pdelta
                pdelta = deltaf
                deltaf = f1-f2
                dnew = dnew + 0.5_wp*deltaf
                if (maxf(n) < pmaxf) maxf(n) = pmaxf
                pmaxf = maxfun
                maxfun = (abs(f1)+abs(f2))/2.0_wp
              end if
            else
              maxf(n) = abs(f1)
              if (iord == 1) then
                dnew = f1-f0
              else if (iord == 2) then
                dnew = (twof0-3.0_wp*f3+f1)/3.0_wp
                if (maxf(n) < abs(f3)) maxf(n) = abs(f3)
                f3 = f2
                f2 = f1
              else
                dnew = c3*f1+c2*f2+c1*f4+c0f0
                if (maxf(n) < abs(f2)) maxf(n) = abs(f2)
                if (maxf(n) < abs(f4)) maxf(n) = abs(f4)
                f4 = f3
                f3 = f2
                f2 = f1
              end if
            end if
            if (abs(h) > 1) then
              dnew = dnew/h**iord
            else
              if (128.0_wp*abs(dnew) > twosup*abs(h)**iord) then
                dnew = twosup/128.0_wp
              else
                dnew = dnew/h**iord
              end if
            end if

            if (init == 0) then
            ! update estimated accuracy of function values
              newacc = acc
              if ((method /= 2 .or. iord == 2) .and. newacc < acc0) newacc = acc0
              if (method /= -1 .and. abs(nhacc1) <= 1.125_wp*abs(heval)/beta4) then
                nhacc1 = heval
                pacc1 = facc1
                call me%faccur(nhacc1,newh1,facc1,x0,twoinf,f0,f1,ifail)
                if (ifail==-1) return
                if (facc1 < pacc1) facc1=(3.0_wp*facc1+pacc1)/4.0_wp
              end if
              if (method /= 1 .and. abs(nhacc2) <= 1.125_wp*abs(heval)/beta4) then
                if (method == 2) then
                  f1 = f2
                  nhacc2 = -heval
                else
                  nhacc2 = heval
                end if
                pacc2 = facc2
                call me%faccur(nhacc2,newh2,facc2,x0,twoinf,f0,f1,ifail)
                if (ifail==-1) return
                if (facc2 < pacc2) facc2 = (3.0_wp*facc2+pacc2)/4.0_wp
              end if
              if (method == 1 .and. newacc < facc1) newacc = facc1
              if (method == -1 .and. newacc < facc2) newacc = facc2
              if (method == 2 .and. newacc < (facc1+facc2)/2.0_wp) &
                      newacc = (facc1+facc2)/2.0_wp
            end if

            ! evaluate successive elements of the current row in the neville
            ! array, estimating and examining the truncation and rounding
            ! errors in each

            contin = n < nmax
            hprev = abs(h)
            fmax = maxf(n)
            if ((method /= 2 .or. iord == 2) .and. fmax < abs(f0)) fmax = abs(f0)

            do k = 1,n
              dprev = d(k)
              d(k) = dnew
              dnew = dprev+(dprev-dnew)/denom(k)
              te = abs(dnew-d(k))
              if (fmax < maxf(n-k)) fmax = maxf(n-k)
              hprev = hprev/beta
              if (newacc >= relacc*fmax) then
                re = newacc*e(k)
              else
                re = relacc*fmax*e(k)
              end if
              if (re /= 0.0_wp) then
                if (hprev > 1) then
                  re = re/hprev**iord
                else if (2.0_wp*re > twosup*hprev**iord) then
                  re = twosup/2.0_wp
                else
                  re = re/hprev**iord
                end if
              end if
              newerr = te+re
              if (te > re) newerr = 1.25_wp*newerr
              if (.not. ignore(k)) then
                if ((init == 0 .or. (k == 2 .and. .not.ignore(1)))  &
                      .and. newerr < error) then
                  deriv = d(k)
                  error = newerr
                end if
                if (init == 1 .and. n == 1) then
                  tderiv = d(1)
                  temerr = newerr
                end if
                if (minerr(k) < twosup/4.0_wp) then
                  s = 4.0_wp*minerr(k)
                else
                  s = twosup
                end if
                if (te > re .or. newerr > s) then
                  ignore(k) = .true.
                else
                  contin = .true.
                end if
                if (newerr < minerr(k)) minerr(k) = newerr
                if (init == 1 .and. n == 2 .and. k == 1 .and. .not.ignore(1)) then
                  if (newerr < temerr) then
                    tderiv = d(1)
                    temerr = newerr
                  end if
                  if (temerr < error) then
                    deriv = tderiv
                    error = temerr
                  end if
                end if
              end if
            end do

            if (n < nmax) d(n+1) = dnew
            if (eps < 0.0_wp) then
              s = abs(eps*deriv)
            else
              s = eps
            end if
            if (error <= s) then
              contin = .false.
            else if (init == 1 .and. (n == 2 .or. ignore(1))) then
              if ((ignore(1) .or. ignore(2)) .and. saved) then
                saved = .false.
                n = 2
                h = beta * save(0)
                heval = beta*save(1)
                maxf(0) = save(2)
                maxf(1) = save(3)
                maxf(2) = save(4)
                d(1) = save(5)
                d(2) = save(6)
                d(3) = save(7)
                minerr(1) = save(8)
                minerr(2) = save(9)
                if (method == 2 .and. iord == 3) then
                  pdelta = save(10)
                  deltaf = save(11)
                  pmaxf = save(12)
                  maxfun = save(13)
                else if (method /= 2 .and. iord >= 2) then
                  f2 = save(10)
                  f3 = save(11)
                  if (iord == 3) f4 = save(12)
                end if
                init = 0
                ignore(1) = .false.
                ignore(2) = .false.
              else if (.not. (ignore(1) .or. ignore(2)) .and. n == 2  &
                    .and. beta4*factor*abs(heval) <= maxh) then
                ! save all current values in case of return to current point
                saved = .true.
                save(0) = h
                save(1) = heval
                save(2) = maxf(0)
                save(3) = maxf(1)
                save(4) = maxf(2)
                save(5) = d(1)
                save(6) = d(2)
                save(7) = d(3)
                save(8) = minerr(1)
                save(9) = minerr (2)
                if (method == 2 .and. iord == 3) then
                  save(10) = pdelta
                  save(11) = deltaf
                  save(12) = pmaxf
                  save(13) = maxfun
                else if (method /= 2 .and. iord >= 2) then
                  save(10) = f2
                  save(11) = f3
                  if (iord == 3) save(12) = f4
                end if
                h = factor*baseh
                heval = h
                baseh = h
                n = -1
              else
                init = 0
                h = beta*h
                heval = beta*heval
              end if
            else if (contin .and. beta*abs(heval) <= maxh) then
              h = beta*h
              heval = beta*heval
            else if (method /= 1) then
              contin = .true.
              if (method == 2) then
                init = 3
                method = -1
                if (iord /= 2) then
                  if (x0 /= 0.0_wp) then
                    dummy1 = 0.0_wp
                    dummy2 = -h0
                    call me%faccur(dummy1,dummy2,acc0,x0,twoinf,f0,f1,ifail)
                    if (ifail==-1) return
                  else
                    acc0 = 0.0_wp
                  end if
                end if
              else
                init = 2
                method = 1
              end if
              n = -1
              signh = -signh
            else
              contin = .false.
            end if

        end do

        if (eps < 0.0_wp) then
          s = abs(eps*deriv)
        else
          s = eps
        end if
        ifail = 0
        if (eps /= 0.0_wp .and. error > s) ifail = 1

    end if

    end subroutine diff
!*****************************************************************************************

!*****************************************************************************************
!>
! This procedure attempts to estimate the level of rounding errors in
! the calculated function values near the point `x0+h0` by fitting a
! least-squares straight-line approximation to the function at the
! six points `x0+h0-j*h1`, (`j = 0,1,3,5,7,9`), and then setting `facc` to
! twice the largest deviation of the function values from this line.
! `hi` is adjusted if necessary so that it is approximately 8 times the
! smallest spacing at which the function values are unequal near `x0+h0`.

    subroutine faccur(me,h0,h1,facc,x0,twoinf,f0,f1,ifail)

    implicit none

    class(diff_func),intent(inout) :: me
    real(wp), intent(inout)  :: h0
    real(wp), intent(inout)  :: h1
    real(wp), intent(out)    :: facc
    real(wp), intent(in)     :: x0
    real(wp), intent(in)     :: twoinf
    real(wp), intent(in)     :: f0
    real(wp), intent(in)     :: f1
    integer, intent(out)     :: ifail  !! 0 if no error, -1 if user termination.

    real(wp) :: a0,a1,f00,f001,f2,deltaf,t0,t1,df(5)
    integer :: j

    ifail = 0
    t0 = 0.0_wp
    t1 = 0.0_wp
    if (h0 /= 0.0_wp) then
      if (x0+h0 /= 0.0_wp) then
        f00 = f1
      else
        h0 = 0.875_wp*h0
        f00 = me%f(x0+h0)
        if (me%stop) then
          ifail = -1
          return
        end if
      end if
      if (abs(h1) >= 32.0_wp*twoinf) h1 = h1/8.0_wp
      if (16.0_wp*abs(h1) > abs(h0)) h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp
      f001 = me%f(x0+h0-h1)
      if (me%stop) then
        ifail = -1
        return
      end if
      if (f001 == f00) then
        if (256.0_wp*abs(h1) <= abs(h0)) then
          h1 = 2.0_wp*h1
          do
              f001 = me%f(x0+h0-h1)
              if (me%stop) then
                ifail = -1
                return
              end if
              if (f001 /= f00 .or. 256.0_wp*abs(h1) > abs(h0)) exit
              h1 = 2.0_wp*h1
          end do
          h1 = 8.0_wp*h1
        else
          h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp
        end if
      else
        if (256.0_wp*twoinf <= abs(h0)) then
          do
              f001 = me%f(x0+h0-h1/2.0_wp)
              if (me%stop) then
                ifail = -1
                return
              end if
              if (f001 == f00 .or. abs(h1) < 4.0_wp*twoinf) exit
              h1 = h1/2.0_wp
          end do
          h1 = 8.0_wp*h1
          if (16.0_wp*abs(h1) > abs(h0)) h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp
        else
          h1 = sign(h1,1.0_wp)*abs(h0)/16.0_wp
        end if
      end if
    else
      f00 = f0
    end if

    do j = 1,5
      f2 = me%f(x0+h0-real(2*j-1,wp)*h1)
      if (me%stop) then
        ifail = -1
        return
      end if
      df(j) = f2 - f00
      t0 = t0+df(j)
      t1 = t1+real(2*j-1,wp)*df(j)
    end do
    a0 = (33.0_wp*t0-5.0_wp*t1)/73.0_wp
    a1 = (-5.0_wp*t0+1.2_wp*t1)/73.0_wp
    facc = abs(a0)
    do j = 1,5
      deltaf = abs(df(j)-(a0+real(2*j-1,wp)*a1))
      if (facc < deltaf) facc = deltaf
    end do
    facc = 2.0_wp*facc

    end subroutine faccur
!*****************************************************************************************

!*****************************************************************************************
    end module diff_module
!*****************************************************************************************


! solve the 1d inviscid burgers equation, in conservative form:
!
!   u_t + [0.5 * u**2 ]_x=0
!   u=u(x,t) (user defined at t=0)
!
! using a second order finite volume predictor-corrector scheme and optional
! gradient limiters. Boundaries are (minimally-tested) zero gradient.
!
! user controled parameters in subroutines "control" and "initial_conditions"
!
! https://github.com/JOThurgood/SimpleCFD/wiki/burgers1.f90

module shared_data
  implicit none
  integer, parameter :: num=selected_real_kind(p=15)
  integer :: nx !number of cells
  integer :: ix
  integer(num) :: step, nsteps
  real(num) :: time=0.0_num, t_end, dt
  real(num) :: x_min, x_max
  real(num) :: dx
  real(num), dimension(:), allocatable :: xb, xc
  real(num), dimension(:), allocatable :: u,u1, u1L, u1R
    !solution and states at half time step indicated by 1
  real(num) :: CFL !cfl modifier
  !keyword codes
  integer :: limiter
  integer, parameter :: lim_unlimited = 1, lim_minmod = 2
  contains
end module shared_data

module setup

  use shared_data

  implicit none

  private

  public :: initial_setup

  contains

  subroutine initial_setup
    call control
    call setup_1dfvgrid
    call initial_conditions
    call warnings
  end subroutine initial_setup

  subroutine control
    !user control variables
    nx = 256
    x_min = 0.0_num
    x_max = 1.0_num
    t_end = 0.10_num
    CFL = 0.8_num
    nsteps = -1    !set to -1 to run till t_end
!    limiter = lim_unlimited
    limiter = lim_minmod
  end subroutine control

  subroutine initial_conditions
    !user set initial profile on a
!    call sinusoid1
    call jump
!    call gaussian
  end subroutine initial_conditions

  subroutine jump
    real(num) :: left, right, x_diaphragm
    x_diaphragm = 0.5
    left = 1.0_num
    right = 2.0_num

    u = left
    do ix = -1,nx+2
      if (xc(ix) .GE. x_diaphragm) u(ix) = right
    enddo
  end subroutine jump

  subroutine sinusoid1
    real(num) :: lo, hi, pi
    pi = 4.0_num * ATAN(1.0_num)
    lo = 1.0_num / 3.0_num
    hi = 2.0_num / 3.0_num
    u = 1.0_num
    do ix = -1,nx+2
      if ( (xc(ix) .ge. lo) .and. (xc(ix) .le. hi) ) then
        u(ix) = u(ix) + 0.5_num * &
          & SIN( (2.0_num * pi * (xc(ix) - 1.0_num/3.0_num)) / &
          & (1.0_num/3.0_num))
      endif
    enddo
  end subroutine sinusoid1

  subroutine setup_1dfvgrid !set up grid and other alloctes

    !with 2 guards below
    allocate(xc(-1:nx+2))  !cell center (cc) - coutns from 1 to nx
    allocate(xb(-2:nx+2))  !cell boundary (cb) - counts from 0 to nx
    allocate(u(-1:nx+2))   !cc + 2 guards

    !no guards needed below
    allocate(u1(0:nx))  !cb - then used to calc a cc var in corrector step
    allocate(u1L(0:nx)) !cb
    allocate(u1R(0:nx)) !cb

    dx = (x_max - x_min) / REAL(nx,num)
    do ix = -2, nx+2
    xb(ix) = x_min + REAL(ix,num) * dx
    if (ix /= -2) xc(ix) = xb(ix) - dx/2.0_num
    enddo

  end subroutine setup_1dfvgrid

  subroutine warnings
    !stub
  end subroutine warnings

  end module setup

module solver

  use shared_data

  implicit none

  private

  public :: update

  contains

  subroutine update
    call boundary
    call set_dt
    call interface_states !i_s and riem  are "predictor" step
    call riemann
    call corrector
    time = time + dt
  end subroutine update

  subroutine boundary
  !zero-gradient (untested)
    u(0) = u(1)
    u(-1) = u(2)
    u(nx+1) = u(nx)
    u(nx+2) = u(nx-1)
  end subroutine boundary

  subroutine set_dt
    dt = 1e15_num
    do ix = 0,nx
      dt = MIN(CFL * dx / abs(u(ix)), dt)
    enddo
  !    print *,'dt debug: step/selected dt', dt
  end subroutine set_dt

  subroutine corrector
  !sign right in eq 6.17 ? maybe just due to rearangement of left and right flux
    real(num) :: fl, fr ! flux
    do ix = 1,nx !cc
      fr = 0.5_num * u1(ix) ** 2
      fl = 0.5_num * u1(ix-1) ** 2
      u(ix)  = u(ix)  - dt / dx * (fr-fl)
    enddo
  endsubroutine corrector

  subroutine interface_states
    real(num) :: slope
    do ix = 0, nx ! states on cb !careful with cc vs cb
      !left state
      if (limiter == lim_minmod) then
        slope = minmod( ( u(ix)-u(ix-1) )/dx, ( u(ix+1)-u(ix) )/dx )
      else
        slope = ( u(ix+1) - u(ix-1) ) / 2.0_num / dx
      endif
      u1L(ix) = u(ix) + 0.5_num * dx * (1.0_num - dt * u(ix) / dx) *  slope
      !right state
      if (limiter == lim_minmod) then
        slope = minmod( ( u(ix+1)-u(ix) )/dx, ( u(ix+2)-u(ix+1) )/dx )
      else
        slope = ( u(ix+2) - u(ix) ) / 2.0_num / dx
      endif
      u1r(ix) = u(ix+1) - 0.5_num * dx * (1.0_num + dt * u(ix) / dx) *  slope
    enddo
  end subroutine interface_states

  subroutine riemann
    real(num) :: S, ul, ur,us
    !keep until sure about their notation
    do ix = 0,nx !a1 + interface states on cb
      ul = u1l(ix)
      ur = u1r(ix)
      S = 0.5_num * (ul + ur)
      if ( ul > ur ) then ! compression
        if ( S > 0.0_num) then
          us = ul
        else if (S < 0.0_num) then
          us = ur
        else
          us = 0.0_num
        endif
      else !uniform flow or expansion
        !(this is normal upwinding,  no assumption on sign of u)
        if (ul > 0.0_num) then
          us = ul
        else if (ur < 0.0_num) then
          us = ur
        else
          us = 0.0_num
        endif
      endif

      u1(ix) = us
   enddo

  end subroutine riemann

  real(num) function minmod(a,b)  ! "a" is an unforunate choice of var name
    real(num), intent(in) :: a, b !change to l and r?
    if ( (abs(a) < abs(b)) .and. (a*b > 0) )then
      minmod = a
    else if ( (abs(a) > abs(b)) .and. (a*b > 0) ) then
      minmod = b
    else
      minmod = 0.0_num
    endif
  end function minmod

end module solver

module diagnostics

  use shared_data

  implicit none

  contains

  subroutine do_io
    integer :: out_unit =10
    call execute_command_line("rm -rf xc.dat u.dat") !dont stream to existing
    open(out_unit, file="xc.dat", access="stream")
    write(out_unit) xc(1:nx)
    close(out_unit)
    open(out_unit, file="u.dat", access="stream")
    write(out_unit) u(1:nx)
    close(out_unit)
    call execute_command_line("python plot_burgers1.py")
  end subroutine do_io

end module diagnostics

program burgers1 !main driver

  use shared_data
  use setup
  use solver
  use diagnostics

  implicit none

  call initial_setup

  do
   if ((step >= nsteps .and. nsteps >= 0) .or. (time >= t_end)) exit
    step = step + 1
    call update
  enddo

  call do_io

  print *, 'Done in',step,'steps', 'with CFL',CFL

end program burgers1


program tg
	use mympiMod
	use fieldMod, only: field
	use vectorMod, only: vfield
	use fluidMod, only: fluid
    use imageMod, only: display

	implicit none

	real, parameter		:: PI = acos(-1.)
	integer,parameter	:: n(3) = 2**7*[1,1,1] ! Grid size
	real,parameter		:: kn = 2*PI/n(3) 	! Wavenumber
	real,parameter		:: Re = 1600		! Reynolds number
	real, parameter		:: nu=1./(kn*Re)	! Viscosity

	type(fluid)			:: flow
	integer				:: b(3)=[4,2,1], m(3), num=9
	real :: tke
	logical :: root

	! -- globals
	call init_mympi(3, set_blocks=b, set_periodic=[.true.,.true.,.true.])
	root = mympi_rank()==0
	m = n/b

	! -- Initialize flow
	call flow%init(m, nu=nu)
	call flow%velocity%eval(tgv)
	call flow%velocity%applyBC()
	call flow%reset_u0()
	flow%dt = flow%velocity%cfl_limit(nu)
	flow%velocity%e%exit = .false.

	! Print info
	if(root) write(*,*) '--- Taylor-Green Vortex --- '
	if(root) print*, 'm', m
	if(root) print*, 'kn', kn
	if(root) print*,
	if(root) print*,
	write(num,*) 't CFL tke  enstrophy'

	! -- Update and keep track of evaluation time
	do while (flow%time*kn.le.14)
		call calc_tke(flow%velocity)
		if (mod(flow%time,2./kn)<flow%dt) call flow%write()
		if (mod(flow%time,0.2/kn)<flow%dt) call display(flow%velocity%vorticity_Z(),'vort',10*kn)
		call flow%update
	end do

	call calc_tke(flow%velocity)
	call flow%write()
	call mympi_end()

contains

	pure function tgv(x) result(v)
		real,intent(in) :: x(3)
		real :: v(3)
		v(1) = -sin(kn*x(1))*cos(kn*x(2))*cos(kn*x(3))
	    v(2) =  cos(kn*x(1))*sin(kn*x(2))*cos(kn*x(3))
	    v(3) = 0.
	end function tgv

	subroutine calc_tke(u)
		use vectorMod, only: vfield, vorticity

		type(vfield), intent(inout) :: u
		integer :: d, num=9
		real :: tke, ens
		real, save :: ens0, tke0
		logical, save :: t0=.true.
		type(vfield) :: vort, uGradTensor(3)

		tke = u%tke()
		call u%gradTensor(uGradTensor)
		call vorticity(uGradTensor, vort)
		ens = vort%tke()

		if (t0) then
			tke0 = tke
			ens0 = ens
			t0 = .false.
		end if

		1 format(2f8.4,2e16.8)
		write(num,1) flow%time*kn, flow%dt, tke/tke0, ens/ens0
		if (root) write(*,1) flow%time*kn, flow%dt, tke/tke0, ens/ens0
	end subroutine calc_tke
end program tg


!> \file p2fCO2.f90
!! \BRIEF
!>    Module with p2fCO2 subroutine - compute fCO2 from pCO2, in situ T, atm pressure, hydrostatic pressure
MODULE mp2fCO2
CONTAINS
!>    Compute fCO2 from arrays of pCO2, in situ temp, atm pressure, & hydrostatic pressure
SUBROUTINE p2fCO2(pCO2, temp, Patm, p, N, fCO2)
  !    Purpose:
  !    Compute fCO2 from arrays of pCO2, in situ temp, atm pressure, & hydrostatic pressure

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

  USE msingledouble
  IMPLICIT NONE

  !> number of records
!f2py intent(hide) n
  INTEGER, INTENT(in) :: N

! INPUT variables
  !> oceanic partial pressure of CO2 [uatm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: pCO2
  !> in situ temperature [C]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: temp
  !> atmospheric pressure [atm]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: Patm
  !> hydrostatic pressure [db]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: p

! OUTPUT variables:
  !> fugacity of CO2 [uatm]
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: fCO2

! LOCAL variables:
  REAL(kind=r8) :: dpCO2, dtemp, tk, dPatm, prb
  REAL(kind=r8) :: Ptot, Rgas_atm, B, Del, xCO2approx, xc2, fugcoeff
  REAL(kind=r8) :: dfCO2

  INTEGER :: i

! REAL(kind=r8) :: sw_ptmp
! EXTERNAL sw_ptmp

  DO i = 1,N
     dpCO2     = DBLE(pCO2(i))
     dtemp     = DBLE(temp(i))
     dPatm     = DBLE(Patm(i))
     tk = 273.15d0 + DBLE(temp(i))     !Absolute temperature (Kelvin)
     prb = DBLE(p(i)) / 10.0d0         !Pressure effect (prb is in bars)
     Ptot = dPatm + prb/1.01325d0      !Total pressure (atmospheric + hydrostatic) [atm]
     Rgas_atm = 82.05736_r8            !R in (cm3 * atm) / (mol * K)  from CODATA (2006)
!    To compute fugcoeff, we need 3 other terms (B, Del, xc2) as well as 3 others above (tk, Ptot, Rgas_atm)
     B = -1636.75d0 + 12.0408d0*tk - 0.0327957d0*(tk*tk) + 0.0000316528d0*(tk*tk*tk)
     Del = 57.7d0 - 0.118d0*tk
!    "x2" term often neglected (assumed = 1) in applications of Weiss's (1974) equation 9
!    x2 = 1 - x1 = 1 - xCO2 (it is very close to 1, but not quite)
!    Let's assume that xCO2 = pCO2. Resulting fugcoeff is identical to 8th digit after the decimal.
     xCO2approx = dpCO2 * 1.e-6_r8
     xc2 = (1.0d0 - xCO2approx)**2
     fugcoeff = EXP( Ptot*(B + 2.0d0*xc2*Del)/(Rgas_atm*tk) )
     dfCO2 = dpCO2 * fugcoeff
     fCO2(i) = SGLE(dfCO2)
  END DO

  RETURN
END SUBROUTINE p2fCO2
END MODULE mp2fCO2


    Program dstevd_example

!     DSTEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dstevd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: norm
      Integer :: i, ifail, info, ldz, liwork, lwork, n
      Character (1) :: job
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), work(:), z(:, :)
      Integer, Allocatable :: iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSTEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      liwork = 5*n + 3
      lwork = n*n + 4*n + 1
      Allocate (d(n), e(n-1), work(lwork), z(ldz,n), iwork(liwork))

!     Read T from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of T
      Call dstevd(job, n, d, e, z, ldz, work, lwork, iwork, liwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) d(1:n)
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors
        Do i = 1, n
          norm = dnrm2(n, z(1,i), 1)
          If (z(1,i)<0.0_dp) Then
            norm = -norm
          End If
          z(1:n, i) = z(1:n, i)/norm
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, (8F8.4))
    End Program


module SmoothingModule
  use KindModule, only: DP, I4B
  use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, &
 &                           DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM14
  implicit none

  contains

  subroutine sSCurve(x,range,dydx,y)
! ******************************************************************************
! COMPUTES THE S CURVE FOR SMOOTH DERIVATIVES BETWEEN X=0 AND X=1
! FROM mfusg smooth SUBROUTINE in gwf2wel7u1.f
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: x
    real(DP), intent(in) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
    real(DP) :: xs
! ------------------------------------------------------------------------------
!   code
!
    s = range
    if ( s < DPREC ) s = DPREC
    xs = x / s
    if (xs < DZERO) xs = DZERO
    if (xs <= DZERO) then
      y = DZERO
      dydx = DZERO
    elseif(xs < DONE)then
      y = -DTWO * xs**DTHREE + DTHREE * xs**DTWO
      dydx = -DSIX * xs**DTWO + DSIX * xs
    else
      y = DONE
      dydx = DZERO
    endif
    return
  end subroutine sSCurve

  subroutine sCubicLinear(x,range,dydx,y)
! ******************************************************************************
! COMPUTES THE S CURVE WHERE DY/DX = 0 at X=0; AND DY/DX = 1 AT X=1.
! Smooths from zero to a slope of 1.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: x
    real(DP), intent(in) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
    real(DP) :: xs
! ------------------------------------------------------------------------------
!   code
!
    s = range
    if ( s < DPREC ) s = DPREC
    xs = x / s
    if (xs < DZERO) xs = DZERO
    if (xs <= DZERO) then
      y = DZERO
      dydx = DZERO
    elseif(xs < DONE)then
      y = -DONE * xs**DTHREE + DTWO * xs**DTWO
      dydx = -DTHREE * xs**DTWO + DFOUR * xs
    else
      y = DONE
      dydx = DZERO
    endif
    return
  end subroutine sCubicLinear

  subroutine sCubic(x,range,dydx,y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1; cubic function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s, aa, bb
    real(DP) :: cof1, cof2, cof3
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    aa = -DSIX/(s**DTHREE)
    bb = -DSIX/(s**DTWO)
    cof1 = x**DTWO
    cof2 = -(DTWO*x)/(s**DTHREE)
    cof3 = DTHREE/(s**DTWO)
    y = cof1 * (cof2 + cof3)
    dydx = (aa*x**DTWO - bb*x)
    if ( x <= DZERO ) then
      y = DZERO
      dydx = DZERO
    else if ( (x - s) > -DPREC ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sCubic

  subroutine sLinear(x,range,dydx,y)
! ******************************************************************************
! Linear smoothing function returns value between 0-1
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    y = DONE - (s - x)/s
    dydx = DONE/s
    if ( y > DONE ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sLinear

  subroutine sQuadratic(x,range,dydx,y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1; quadratic function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    y = (x**DTWO) / (s**DTWO)
    dydx = DTWO*x/(s**DTWO)
    if ( y > DONE ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sQuadratic

  subroutine sChSmooth(h, smooth, dwdh)
! ******************************************************************************
! Function to smooth channel variables during channel drying
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: h
    real(DP), intent(inout) :: smooth
    real(DP), intent(inout) :: dwdh
    !--local variables
    real(DP) :: s, aa, ad, b, x, y
! ------------------------------------------------------------------------------
!   code
!
    smooth = DZERO
    s = DEM5
    x = h
    if ( x-s > DZERO ) then
      smooth = DONE
      dwdh = DZERO
    else
      aa = -DONE / (s**DTWO)
      ad = -DTWO / (s**DTWO)
      b = DTWO / s
      y = aa * x**DTWO + b*x
      dwdh = (ad*x + b)
      if ( x <= DZERO ) then
        y = DZERO
        dwdh = DZERO
      else if ( x-s > -DEM14 ) then
        y = DONE
        dwdh = DZERO
      end if
      smooth = y
    end if
    return
end subroutine sChSmooth

  function sLinearSaturation(top, bot, x) result(y)
! ******************************************************************************
! Linear smoothing function returns value between 0-1;
! Linear saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    ! -- local
    real(DP) :: b
! ------------------------------------------------------------------------------
!   code
!
    b = top - bot
    if (x < bot) then
      y = DZERO
    else if (x > top) then
      y = DONE
    else
      y = (x - bot) / b
    end if
    return
  end function sLinearSaturation

  function sCubicSaturation(top, bot, x, eps) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in), optional :: eps
    ! -- local
    real(DP) :: teps
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM2
    end if
    w = x - bot
    b = top - bot
    s = teps * b
    cof1 = DONE / (s**DTWO)
    cof2 = DTWO / s
    if (w < DZERO) then
      y = DZERO
    else if (w < s) then
      y = -cof1 * (w**DTHREE) + cof2 * (w**DTWO)
    else if (w < (b-s)) then
      y = w / b
    else if (w < b) then
      y = DONE + cof1 * ((b - w)**DTHREE) - cof2 * ((b - w)**DTWO)
    else
      y = DONE
    end if

    return
  end function sCubicSaturation

  function sQuadraticSaturation(top, bot, x, eps) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), optional, intent(in) :: eps
    ! -- local
    real(DP) :: teps
    real(DP) :: b
    real(DP) :: br
    real(DP) :: bri
    real(DP) :: av
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM6
    end if
    b = top - bot
    if (b > DZERO) then
      if (x < bot) then
        br = DZERO
      else if (x > top) then
        br = DONE
      else
        br = (x - bot) / b
      end if
      av = DONE / (DONE - teps)
      bri = DONE - br
      if (br < DZERO) then
        y = DZERO
      elseif (br < teps) then
        y = av * DHALF * (br*br) / teps
      elseif (br < (DONE-teps)) then
        y = av * br + DHALF * (DONE - av)
      elseif (br < DONE) then
        y = DONE - ((av * DHALF * (bri * bri)) / teps)
      else
        y = DONE
      end if
    else
      if (x < bot) then
        y = DZERO
      else
        y = DONE
      end if
    end if

    return
  end function sQuadraticSaturation

  function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! van Genuchten saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in) :: alpha
    real(DP), intent(in) :: beta
    real(DP), intent(in) :: sr
    ! -- local
    real(DP) :: b
    real(DP) :: pc
    real(DP) :: gamma
    real(DP) :: seff
! ------------------------------------------------------------------------------
!   code
!
    b = top - bot
    pc = (DHALF * b) - x
    if (pc <= DZERO) then
      y = DZERO
    else
      gamma = DONE - (DONE / beta)
      seff = (DONE + (alpha * pc)**beta)**gamma
      seff = DONE / seff
      y = seff * (DONE - sr) + sr
    end if

    return
  end function svanGenuchtenSaturation

  function sQuadraticSaturationDerivative(top, bot, x, eps) result(y)
! ******************************************************************************
! Derivative of nonlinear smoothing function returns value between 0-1;
! Derivative of the quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), optional, intent(in) :: eps
    ! -- local
    real(DP) :: teps
    real(DP) :: b
    real(DP) :: br
    real(DP) :: bri
    real(DP) :: av
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM6
    end if
    b = top - bot
    if (x < bot) then
      br = DZERO
    else if (x > top) then
      br = DONE
    else
      br = (x - bot) / b
    end if
    av = DONE / (DONE - teps)
    bri = DONE - br
    if (br < DZERO) then
      y = DZERO
    elseif (br < teps) then
      y = av * br / teps
    elseif (br < (DONE-teps)) then
      y = av
    elseif (br < DONE) then
      y = av * bri / teps
    else
      y = DZERO
    end if
    y = y / b

    return
  end function sQuadraticSaturationDerivative

  function sQSaturation(top, bot, x) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Cubic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    ! -- local
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    w = x - bot
    b = top - bot
    s = w / b
    cof1 = -DTWO / b**DTHREE
    cof2 = DTHREE / b**DTWO
    if (s < DZERO) then
      y = DZERO
    else if(s < DONE) then
      y = cof1 * w**DTHREE + cof2 * w**DTWO
    else
      y = DONE
    end if

    return
  end function sQSaturation

  function sQSaturationDerivative(top, bot, x) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Cubic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    ! -- local
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    w = x - bot
    b = top - bot
    s = w / b
    cof1 = -DSIX / b**DTHREE
    cof2 = DSIX / b**DTWO
    if (s < DZERO) then
      y = DZERO
    else if(s < DONE) then
      y = cof1 * w**DTWO + cof2 * w
    else
      y = DZERO
    end if

    return
  end function sQSaturationDerivative

end module SmoothingModule


!> @ingroup is_sorted_#ORD_NAME#
!>
!> @brief
!> Check if a vector of real values is sorted by a decending order.
!>
!> @details
!> Check if a vector of real values is sorted by a decending order. Returns a logical value indicating if the vector is sorted.
!>
!> @result  sorted
!> Indicates if the vector is sorted.
!>
!> | Value | Meaning                  |
!> |:-----:|:------------------------ |
!> | true  | The vector is sorted     |
!> | false | The vector is not sorted |
!>

!> @param x
!> The vector to be checked for being sorted.
!>
!> @note
!> Empty and single value vectors are considered sorted.
!>
!> @author Arin R. Bratt
!> @date 10/07/2014
pure function is_sorted_dec_real(x) result(sorted)

  ! Result
  logical :: sorted

  ! Arguments
  real, intent(in) :: x(:)

  ! Variables
  integer :: i

  ! This structure avoides checking empty or single value vectors, which are always considered sorted.
  do i = 2,size(x,1)
     if (x(i - 1) < x(i)) then
        sorted = .false.
        return
     end if
  end do
  sorted = .true.
end function is_sorted_dec_real


	SUBROUTINE strapzd(func,a,b,s,n)
	use mo_kind
        use mo_nrutil, ONLY : arth
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: a,b
	REAL(SP), INTENT(INOUT) :: s
	INTEGER(I4), INTENT(IN) :: n
	INTERFACE
		FUNCTION func(x)
		use mo_kind
		REAL(SP), DIMENSION(:), INTENT(IN) :: x
		REAL(SP), DIMENSION(size(x)) :: func
		END FUNCTION func
	END INTERFACE
	REAL(SP) :: del,fsum
	INTEGER(I4) :: it
	if (n == 1) then
		s=0.5_sp*(b-a)*sum(func( (/ a,b /) ))
	else
		it=2**(n-2)
		del=(b-a)/it
		fsum=sum(func(arth(a+0.5_sp*del,del,it)))
		s=0.5_sp*(s+del*fsum)
	end if
	END SUBROUTINE strapzd

	SUBROUTINE dtrapzd(func,a,b,s,n)
	use mo_kind
        use mo_nrutil, ONLY : arth
	IMPLICIT NONE
	REAL(DP), INTENT(IN) :: a,b
	REAL(DP), INTENT(INOUT) :: s
	INTEGER(I4), INTENT(IN) :: n
	INTERFACE
		FUNCTION func(x)
		use mo_kind
		REAL(DP), DIMENSION(:), INTENT(IN) :: x
		REAL(DP), DIMENSION(size(x)) :: func
		END FUNCTION func
	END INTERFACE
	REAL(DP) :: del,fsum
	INTEGER(I4) :: it
	if (n == 1) then
		s=0.5_dp*(b-a)*sum(func( (/ a,b /) ))
	else
		it=2**(n-2)
		del=(b-a)/it
		fsum=sum(func(arth(a+0.5_dp*del,del,it)))
		s=0.5_dp*(s+del*fsum)
	end if
	END SUBROUTINE dtrapzd


program main
    ! solve the Schrodinger equation of a particle in an infinite potential well with central barrier with Exact Diagonalization

    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)

    ! local vars
    integer :: i, j, m, m1, ifactorial, mfactorial, iminus2mfactorail, Nx, LWORK, INFO
    real(dp) :: Xmax, dx, V0
    real(dp), allocatable :: x(:), Vpot(:), Ham(:,:), basis(:,:), W(:), WORK(:)

    ! executable
    Xmax = -1.d0
    do while (Xmax < 0.d0)
        write(*,*) 'Please indicate the range of x, [-Xmax,Xmax]; Xmax ='
        read(*,*) Xmax
    end do

    Nx = -1
    do while (Nx <= 0)
        write(*,*) 'Please specify the # of slices between [0,Xmax], Nx ='
        read(*,*) Nx
    end do

    ! memory dynamical allocation
    allocate(x(-Nx:Nx))
    allocate(Vpot(-Nx:Nx))

    dx = Xmax / dble(Nx)
    do i = -Nx, Nx
        x(i) = dx * dble(i)
        Vpot(i) = .5d0 * ((x(i)**2 - 1.d0)**2 / 4.d0 - x(i)**2)
    end do

    allocate(basis(2 * Nx + 1, 2 * Nx +1))
    basis = 0.d0
    do i = 1, 2 * Nx + 1    ! order of basis function + 1
        write(*,*) i
        ifactorial = 1
        do m1 = 1, (i - 1)
            ifactorial = ifactorial * m1
        end do
        do j = 1, 2 * Nx + 1    ! coordinate index
            if (mod((i - 1), 2) /= 0) then
                ! (i - 1) is odd
                do m = 0, ((i - 1) - 1) / 2
                    mfactorial = 1
                    do m1 = 1, m
                        mfactorial = mfactorial * m1
                    end do
                    iminus2mfactorail = 1
                    do m1 = 1, (i - 1) - 2 * m
                        iminus2mfactorail = iminus2mfactorail * m1
                    end do
                    basis(i,j) = basis(i,j)&
                     + dble((-1)**m) * dble(ifactorial) / dble(mfactorial) / dble(iminus2mfactorail) *&
                     (2.d0 * x(j - Nx -1))**((i - 1) - 2 * m)
                end do
                write(*, '(3f32.16)', advance = 'no')&
                 basis(i,j), exp(-x(j - Nx - 1)**2 / 2.d0), basis(i,j) * exp(-x(j - Nx - 1)**2 / 2.d0)
                basis(i,j) = basis(i,j) * exp(-x(j - Nx - 1)**2 / 2.d0)
            else
                ! (i - 1) is even
                do m = 0, (i - 1) / 2
                    mfactorial = 1
                    do m1 = 1, m
                        mfactorial = mfactorial * m1
                    end do
                    iminus2mfactorail = 1
                    do m1 = 1, (i - 1) - 2 * m
                        iminus2mfactorail = iminus2mfactorail * m1
                    end do
                    basis(i,j) = basis(i,j)&
                     + dble((-1)**m) * dble(ifactorial) / dble(mfactorial) / dble(iminus2mfactorail) *&
                     (2.d0 * x(j - Nx - 1))**((i - 1) - 2 * m)
                end do
                write(*, '(3f32.16)', advance = 'no')&
                 basis(i,j), exp(-x(j - Nx - 1)**2 / 2.d0), basis(i,j) * exp(-x(j - Nx - 1)**2 / 2.d0)
                basis(i,j) = basis(i,j) * exp(-x(j - Nx - 1)**2 / 2.d0)
            end if
            write(*,*)
        end do
    end do

    ! do i = 1, 2 * Nx + 1
    !     write(*, '(f20.8,f20.12)', advance = 'no') x(i - Nx - 1)
    !     do j = 1, 2 * Nx + 1
    !         write(*,'(f12.6)', advance = 'no') basis(j,i)
    !     end do
    !     write(*,*)
    ! end do

    allocate(Ham(2 * Nx + 1, 2 * Nx + 1))
    Ham = 0.d0
    do i = 1, 2 * Nx + 1
        do j = i, 2 * Nx + 1
            call Simpson(2 * Nx + 1, basis(i, 1:2 * Nx + 1), basis(j, 1:2 * Nx + 1), Vpot(-Nx:Nx) - .5d0, dx, V0)
            Ham(i, j) = V0
            if (i == j) then
                Ham(i, j) = Ham(i, j) + (i - .5d0)
            end if
            Ham(j, i) = Ham(i, j)
        end do
    end do

    allocate(W(2 * Nx + 1))
    LWORK = 10 * Nx
    allocate(WORK(LWORK))
    call DSYEV('V', 'U', 2 * Nx + 1, Ham, 2 * Nx + 1, W, WORK, LWORK, INFO)

    if (INFO == 0) then
        open(unit = 1, file = '4-energy-ExactDiagonalization.txt', status = 'unknown')
        open(unit = 2, file = '4-wavefunction-ExactDiagonalization.txt', status = 'unknown')

        ! multiply the coefficient (which is stored in Ham now) with the basis function to get the wave function
        Ham = matmul(transpose(basis), Ham)

        ! output results
        do i = 1, 2 * Nx + 1
            write(1, '(i4,f20.12)') i, W(i)
            write(2, '(f12.16)', advance = 'no') x(i - Nx -1)
            do j = 1, 2 * Nx + 1
                write(2, '(f12.6)', advance = 'no') Ham(i,j)
            end do
            write(2, *)
        end do
        close(1)
        close(2)
    else
        write(*, *) 'Diagonalization went wrong! aborting ...'
        ! open(unit = 1, file = 'tmp.txt', status = 'unknown')
        ! test
        ! do i = 1, 2 * Nx + 1
        !     write(1, '(f20.8,f20.12)', advance = 'no') x(i - Nx - 1)
        !     do j = 1, 2 * Nx + 1
        !         write(1,'(f12.6)', advance = 'no') basis(j,i)
        !     end do
        !     write(1,*)
        ! end do
        ! close(1)
        stop
    end if

    deallocate(Ham)
    deallocate(basis, W, WORK)
    deallocate(x, Vpot)

end program main

subroutine Simpson(N, u, v, Vpot, dx, V0)
    ! calculate the integral of the product of u, v, and Vpot from -Xmax to Xmax with compound simpson formula

    implicit none
    integer :: N
    real(8), intent(in) :: u(N), v(N), Vpot(N), dx
    real(8), intent(out) :: V0

    ! local vars
    integer :: i
    real(8) :: Work(N)

    if (mod(N, 2) == 0) then
    ! Simpson does not work for integral of array with even number of elements
        write(*, *) 'Array with even elements, Simpson does not know how to work!'
    end if

    do i = 1, N
        Work(i) = Vpot(i) * u(i) * v(i)
    end do

    V0 = Work(1) + Work(N)
    do i = 2, N - 1, 2
        V0 = V0 + 4.d0 * Work(i)
    end do
    do i = 3, N - 2, 2
        V0 = V0 + 2.d0 * Work(i)
    end do
    V0 = V0 * dx / 3.d0

end subroutine Simpson


      SUBROUTINE sdr2sdr(line,soln)
C----
C Compute the second nodal plane of a double couple source
C algebraically.
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)
      REAL*8 str1,dip1,rak1,str,dip,rak,str2,dip2,rak2
      REAL*8 xn1,yn1,zn1,xr,yr,zr,xs2,ys2,zs2,dum1
C Get input strike, dip, rake in degrees; convert to radians
      read(line,*) str1,dip1,rak1
      str = d2r*str1
      dip = d2r*dip1
      rak = d2r*rak1
C Normal vector to input plane
      xn1 =  dsin(dip)*dcos(str)
      yn1 = -dsin(dip)*dsin(str)
      zn1 =  dcos(dip)
C Rake vector of input plane
      xr =  dcos(rak)*dsin(str) - dcos(dip)*dsin(rak)*dcos(str)
      yr =  dcos(rak)*dcos(str) + dcos(dip)*dsin(rak)*dsin(str)
      zr =  dsin(rak)*dsin(dip)
      ! If vector points downward, flip it
      if (zr.lt.0.0d0) then
          xr = -xr
          yr = -yr
          zr = -zr
          xn1 = -xn1
          yn1 = -yn1
          zn1 = -zn1
      endif
C Compute new strike
      str2 = r2d*datan2(xr,yr) - 90.0d0
      if (str2.gt.360.0d0) str2 = str2 - 360.0d0
      if (str2.lt.0.0d0) str2 = str2 + 360.0d0
C Compute new dip
      dip2 = r2d*datan(dsqrt(xr*xr+yr*yr)/zr)
C Compute new rake
      xs2 = dsin(str2*d2r)
      ys2 = dcos(str2*d2r)
      zs2 = 0.0d0
      rak2 = r2d*dacos(xn1*xs2+yn1*ys2+zn1*zs2)
C Check rake is pos or neg
      dum1 = xs2*yn1 - ys2*xn1
      if (dum1.lt.0.0d0) then
          rak2 = -rak2
      endif
C Write strike, dip, and rake in degrees
      write(soln,9999) str2,dip2,rak2
 9999 format(3F6.0)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE sdr2mij(line,soln)
C----
C Compute the (unit) moment tensor from double couple strike, dip, and
C rake angles.
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2)
      REAL*8 str1,dip1,rak1,str,dip,rak
      REAL*8 cs,ss,s2s,c2s,cd,sd,s2d,c2d,cr,sr
      REAL*8 mrr,mtt,mpp,mrt,mrp,mtp
C Get input strike, dip, rake in degrees; convert to radians
      read(line,*) str1,dip1,rak1
      str = d2r*str1
      dip = d2r*dip1
      rak = d2r*rak1
C Derived trigonometric variables
      cs  = dcos(str)
      ss  = dsin(str)
      s2s = dsin(2.0d0*str)
      c2s = dcos(2.0d0*str)
      cd  = dcos(dip)
      sd  = dsin(dip)
      s2d = dsin(2.0d0*dip)
      c2d = dcos(2.0d0*dip)
      cr  = dcos(rak)
      sr  = dsin(rak)
C Moment tensor components in GCMT convention (r,t,p)
      mrr =  (            s2d*sr      )
      mtt = -(sd*cr*s2s + s2d*sr*ss*ss)
      mpp =  (sd*cr*s2s - s2d*sr*cs*cs)
      mrt = -(cd*cr*cs  + c2d*sr*ss   )
      mrp =  (cd*cr*ss  - c2d*sr*cs   )
      mtp = -(sd*cr*c2s + s2d*sr*ss*cs)
C Write moment tensor components
      write(soln,9999) mrr,mtt,mpp,mrt,mrp,mtp
 9999 format(6(1PE14.6))
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE sdr2ter(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 p(3),n(3),t(3),fth,fss,fno
      call sdr2pnt(line,soln)
      read(soln,*) p(1),p(2),p(3),n(1),n(2),n(3),t(1),t(2),t(3)
      fno = datan(p(3)/dsqrt(p(1)*p(1)+p(2)*p(2)))
      fss = datan(n(3)/dsqrt(n(1)*n(1)+n(2)*n(2)))
      fth = datan(t(3)/dsqrt(t(1)*t(1)+t(2)*t(2)))
      fno = dsin(fno)*dsin(fno)
      fss = dsin(fss)*dsin(fss)
      fth = dsin(fth)*dsin(fth)
      write(soln,1001) fth,fss,fno
 1001 format(3F7.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE sdr2sv(line,soln)
      IMPLICIT none
      REAL*8 pi,r2d,d2r
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)
      CHARACTER*180 line,soln
      REAL*8 s1,d1,r1,x1,y1,z1,n1,e1
      read(line,*) s1,d1,r1
      s1 = s1*d2r
      d1 = d1*d2r
      r1 = r1*d2r
C x in strike direction, y in hor updip direction
      x1 = dcos(r1)
      y1 = dsin(r1)*dcos(d1)
      z1 = dsin(r1)*dsin(d1)
C rotate to east-north
      e1 = x1*dsin(s1) - y1*dcos(s1)
      n1 = x1*dcos(s1) + y1*dsin(s1)
      write(soln,1001) datan2(e1,n1)*r2d,
     1                 datan2(z1,dsqrt(e1*e1+n1*n1))*r2d
 1001 format(2F10.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2ter(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 p(3),n(3),t(3),fth,fss,fno
      read(line,*) p(1),p(2),p(3),n(1),n(2),n(3),t(1),t(2),t(3)
      fno = datan(p(3)/dsqrt(p(1)*p(1)+p(2)*p(2)))
      fss = datan(n(3)/dsqrt(n(1)*n(1)+n(2)*n(2)))
      fth = datan(t(3)/dsqrt(t(1)*t(1)+t(2)*t(2)))
      fno = dsin(fno)*dsin(fno)
      fss = dsin(fss)*dsin(fss)
      fth = dsin(fth)*dsin(fth)
      write(soln,1001) fth,fss,fno
 1001 format(3F7.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2mag(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 mom
      call pnt2mom(line,soln)
      read(soln,*) mom
      write(line,1001) mom
 1001 format(1P1E14.6)
      call mom2mag(line,soln)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2mom(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 dum,p,n,t,mom
      read(line,*) dum,dum,dum,dum,dum,dum,dum,dum,dum,p,n,t
      mom = 0.5d0*(dabs(p)+dabs(t))
      write(soln,1001) mom
 1001 format(1P1E14.6)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2ter(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 p(3),n(3),t(3),fth,fss,fno
      call mij2pnt(line,soln)
      read(soln,*) p(1),p(2),p(3),n(1),n(2),n(3),t(1),t(2),t(3)
      fno = datan(p(3)/dsqrt(p(1)*p(1)+p(2)*p(2)))
      fss = datan(n(3)/dsqrt(n(1)*n(1)+n(2)*n(2)))
      fth = datan(t(3)/dsqrt(t(1)*t(1)+t(2)*t(2)))
      fno = dsin(fno)*dsin(fno)
      fss = dsin(fss)*dsin(fss)
      fth = dsin(fth)*dsin(fth)
      write(soln,1001) fth,fss,fno
 1001 format(3F7.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2mom(line,soln)
C----
C Compute the seismic moment (N-m) from moment tensor elements (N-m)
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 dum,p,n,t,mom
      call mij2pnt(line,soln)
      read(soln,*) dum,dum,dum,dum,dum,dum,dum,dum,dum,p,n,t
      mom = 0.5d0*(dabs(p)+dabs(t))
      write(soln,1001) mom
 1001 format(1P1E14.6)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mom2mag(line,soln)
C----
C Compute the magnitude from seismic moment (N-m)
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 mom,mag
      read(line,*) mom
      mag = 2.0d0/3.0d0*dlog10(mom*1.0d7)-10.7d0
      write(soln,1001) mag
 1001 format(1F8.2)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mag2mom(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 mom,mag
      read(line,*) mag
      mom = 10**((mag+10.7d0)*1.5d0)*1.0d-7
      write(soln,1001) mom
 1001 format(1P1E14.6)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2mag(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 mom
      call mij2mom(line,soln)
      read(soln,*) mom
      write(line,1001) mom
 1001 format(1P1E14.6)
      call mom2mag(line,soln)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE sdr2pnt(line,soln)
C----
C Compute the (unit) P, N, T axes from double couple strike, dip, and
C rake angles.
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 mrr,mtt,mpp,mrt,mrp,mtp
C Convert to moment tensor components
      call sdr2mij(line,soln)
      read(soln,*) mrr,mtt,mpp,mrt,mrp,mtp
      write(line,9989) mrr,mtt,mpp,mrt,mrp,mtp
 9989 format(6(1P1E14.6))
C Convert to P, N, T axes
      call mij2pnt(line,soln)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pntxyz2plaz(line,soln)
      IMPLICIT none
      REAL*8 pi,r2d
      PARAMETER (pi=4.0d0*datan(1.0d0),r2d=1.8d2/pi)
      CHARACTER*180 line,soln
      REAL*8 PNT(3,3),H
      REAL*8 pl(3),az(3),mg(3)
      INTEGER i
C Read in P, N, T vectors in Cartesian coordinates
      read(line,*) PNT(1,1),PNT(1,2),PNT(1,3),
     1             PNT(2,1),PNT(2,2),PNT(2,3),
     2             PNT(3,1),PNT(3,2),PNT(3,3)
C Compute plunge, azimuth, length
      do 103 i = 1,3
          H = dsqrt(PNT(i,1)*PNT(i,1)+PNT(i,2)*PNT(i,2))
          pl(i) = datan(PNT(i,3)/H)*r2d
          az(i) = datan2(PNT(i,1),PNT(i,2))*r2d
          if (pl(i).gt.0.0d0) then
              az(i) = az(i) + 1.8d2
              pl(i) = -pl(i)
          endif
          pl(i) = -pl(i)
          mg(i) = dsqrt(H*H+PNT(i,3)*PNT(i,3))
  103 continue
C Write to new output
      write(soln,1001) az(1),pl(1),mg(1),az(2),pl(2),mg(2),az(3),pl(3),
     1                 mg(3)
 1001 format(3(2F6.0,1P1E14.6))
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2sdr(line,soln)
C----
C Compute the best fitting double couple source (strike, dip, rake) of a
C moment tensor source.
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      INTEGER n,lda,lwmax
      PARAMETER (n=3,lda=n,lwmax=250)
      INTEGER info,lwork
      REAL*8 a(lda,n),w(n),work(lwmax),m(6)
      REAL*8 p(3),t(3),slip(3),normal(3),str,dip,rak,str2,dip2,rak2
      INTEGER i
C Get input moment tensor (mrr, mtt, mpp, mrt, mrp, mtp; r=z, t=n, p=e)
C Moment tensor components (r=z, t=e, p=n):
      read(line,*) m(1),m(2),m(3),m(4),m(5),m(6)
      a(3,3) =  m(1)     ! mrr =  mzz
      a(2,2) =  m(2)     ! mtt =  myy
      a(1,1) =  m(3)     ! mpp =  mxx
      a(2,3) = -m(4)     ! mrt = -myz
      a(3,2) = -m(4)
      a(1,3) =  m(5)     ! mrp =  mxz
      a(3,1) =  m(5)
      a(1,2) = -m(6)     ! mtp = -mxy
      a(1,2) = -m(6)
C Query the optimal workspace
      lwork = -1
      call dsyev('Vectors','Upper',n,a,lda,w,work,lwork,info)
      lwork = min(lwmax,int(work(1)))
C Solve eigenproblem
      call dsyev('Vectors','Upper',n,a,lda,w,work,lwork,info)
C Compute best-fitting focal mechanism
      do 103 i = 1,3
          p(i) = a(i,1)
          t(i) = a(i,3)
  103 continue
      call pt2un(p,t,slip,normal)
      call un2sdr(slip,normal,str,dip,rak)
      write(line,*) str,dip,rak
      call sdr2sdr(line,soln)
      read(soln,*) str2,dip2,rak2
      write(soln,1001) str,dip,rak,str2,dip2,rak2
 1001 format(6F6.0)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2sv(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 s1,d1,r1,s2,d2,r2,az1,pl1,az2,pl2
      call mij2sdr(line,soln)
      read(soln,*) s1,d1,r1,s2,d2,r2
      write(line,*) s1,d1,r1
      call sdr2sv(line,soln)
      read(soln,*) az1,pl1
      write(line,*) s2,d2,r2
      call sdr2sv(line,soln)
      read(soln,*) az2,pl2
      write(soln,1001) az1,pl1,az2,pl2
 1001 format(2F10.3,X,2F10.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2sdr(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 p(3),n(3),t(3),slip(3),normal(3),s1,d1,r1,s2,d2,r2
      read(line,*) p(1),p(2),p(3),n(1),n(2),n(3),t(1),t(2),t(3)
      call pt2un(p,t,slip,normal)
      call un2sdr(slip,normal,s1,d1,r1)
      write(line,*) s1,d1,r1
      call sdr2sdr(line,soln)
      read(soln,*) s2,d2,r2
      write(soln,1001) s1,d1,r1,s2,d2,r2
 1001 format(6F6.0)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2sv(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 s1,d1,r1,s2,d2,r2,az1,pl1,az2,pl2
      call pnt2sdr(line,soln)
      read(soln,*) s1,d1,r1,s2,d2,r2
      write(line,*) s1,d1,r1
      call sdr2sv(line,soln)
      read(soln,*) az1,pl1
      write(line,*) s2,d2,r2
      call sdr2sv(line,soln)
      read(soln,*) az2,pl2
      write(soln,1001) az1,pl1,az2,pl2
 1001 format(2F10.3,X,2F10.3)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2dcp(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 dum,p,n,t,dcp
      call mij2pnt(line,soln)
      read(soln,*) dum,dum,dum,dum,dum,dum,dum,dum,dum,p,n,t
      if (dabs(p).gt.dabs(t)) then
          dcp = 1.0d0 - 2.0d0*dabs(n/p)
      else
          dcp = 1.0d0 - 2.0d0*dabs(n/t)
      endif
      write(soln,1001) dcp
 1001 format(F5.2)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE mij2pnt(line,soln)
C----
C Compute P, N, and T vectors from a moment tensor input
C----
      IMPLICIT none
      CHARACTER*180 line,soln
      INTEGER n,lda,lwmax
      PARAMETER (n=3,lda=n,lwmax=250)
      INTEGER info,lwork
      REAL*8 a(lda,n),w(n),work(lwmax),m(6)
      REAL*8 p(3),o(3),t(3)
C Get input moment tensor (mrr, mtt, mpp, mrt, mrp, mtp; r=z, t=n, p=e)
C Moment tensor components (r=z, t=e, p=n):
      read(line,*) m(1),m(2),m(3),m(4),m(5),m(6)
      a(3,3) =  m(1)     ! mrr =  mzz
      a(2,2) =  m(2)     ! mtt =  myy
      a(1,1) =  m(3)     ! mpp =  mxx
      a(2,3) = -m(4)     ! mrt = -myz
      a(3,2) = -m(4)
      a(1,3) =  m(5)     ! mrp =  mxz
      a(3,1) =  m(5)
      a(1,2) = -m(6)     ! mtp = -mxy
      a(1,2) = -m(6)
C Query the optimal workspace
      lwork = -1
      call dsyev('Vectors','Upper',n,a,lda,w,work,lwork,info)
      lwork = min(lwmax,int(work(1)))
C Solve eigenproblem
      call dsyev('Vectors','Upper',n,a,lda,w,work,lwork,info)
      p(1) = a(1,1)
      p(2) = a(2,1)
      p(3) = a(3,1)
      o(1) = a(1,2)
      o(2) = a(2,2)
      o(3) = a(3,2)
      t(1) = a(1,3)
      t(2) = a(2,3)
      t(3) = a(3,3)
C Write P, N, and T vectors
      write(soln,1001) p(1),p(2),p(3),o(1),o(2),o(3),t(1),t(2),t(3),
     1                 w(1),w(2),w(3)
 1001 format(9F7.3,3(1P1E14.6))
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pt2un(p,t,slip,normal)
C----
C Compute unit normal and slip vectors from P and T axes
C----
      IMPLICIT none
      REAL*8 sqrt2
      PARAMETER (sqrt2=dsqrt(2.0d0))
      REAL*8 p(3),t(3),slip(3),normal(3)
      INTEGER i
      do 101 i = 1,3
          slip(i)   = (t(i)+p(i))/sqrt2
          normal(i) = (t(i)-p(i))/sqrt2
  101 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE un2sdr(slip,normal,s,d,r)
C----
C Compute strike, dip, rake from slip and normal to plane
C----
      IMPLICIT none
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)
      REAL*8 slip(3),normal(3),s,d,r
      REAL*8 hor,st(3),dum
      INTEGER i
C      do 101 i = 1,3
C          slip(i)   = slip(i)
C  101 continue
      if (normal(3).lt.0.0d0) then
          do 102 i = 1,3
              slip(i)   = -slip(i)
              normal(i) = -normal(i)
  102     continue
      endif
      s = datan2(normal(1),normal(2))/d2r - 90.0d0 ! strike
      if (s.lt.0.0d0) s = s + 360.0d0
      hor = dsqrt(normal(1)*normal(1)+normal(2)*normal(2))
      d = datan2(hor,normal(3))/d2r                ! dip
      st(1) = dsin(s*d2r) ! components of strike
      st(2) = dcos(s*d2r) ! components of strike
      st(3) = 0.0d0       ! components of strike
      r = dacos(st(1)*slip(1)+st(2)*slip(2))*r2d
C Check rake is pos or neg
      dum = st(1)*slip(2)-st(2)*slip(1)
      if (dum.lt.0.0d0) then
          r = -r
      endif
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE pnt2dcp(line,soln)
      IMPLICIT none
      CHARACTER*180 line,soln
      REAL*8 dum,p,n,t,dcp
      read(line,*) dum,dum,dum,dum,dum,dum,dum,dum,dum,p,n,t
      if (dabs(p).gt.dabs(t)) then
          dcp = 1.0d0 - 2.0d0*dabs(n/p)
      else
          dcp = 1.0d0 - 2.0d0*dabs(n/t)
      endif
      write(soln,1001) dcp
 1001 format(F5.2)
      RETURN
      END


      SUBROUTINE pyrmd4(dvol,x,xcen)
!---------------------------------------------------
!***  calculates volume of a pyramid with a quad base (1GP scheme)
!---------------------------------------------------

      IMPLICIT NONE

      REAL(kind=8):: dvol,x(3,4),xcen(3)

      REAL(kind=8) :: x1(3),x2(3),x3(3),xp(3),xcq(3)

      x1(:) = -x(:,1)+x(:,2)+x(:,3)-x(:,4)
      x2(:) = -x(:,1)-x(:,2)+x(:,3)+x(:,4)
      xcq(:) = .25d0 * (x(:,1)+x(:,2)+x(:,3)+x(:,4))
      x3(:) = xcq(:)-xcen(:)
      CALL vecpro(x1,x2,xp)
      dvol = DOT_PRODUCT(x3,xp)
      dvol = dvol/12.d0

      END SUBROUTINE pyrmd4


      subroutine lagrange_intpol(y,dy,dymax,u,uint,t,tint,r,rint,
     &                           ru,ruint,mmax)
C...|....1....|....2....|....3....|....4....|....5....|....6....|....7..
C     interpolate between non-aequidistant points through lagrange
C     polynomials
C.......................................................................
      implicit none

      integer dymax,mmax,m_l,j
      integer index
      real y(dymax),u(dymax),t(dymax),ru(dymax),r(dymax)
      real uint(mmax),tint(mmax),rint(mmax),ruint(mmax)
      real y1,y2,y3,y4,y5,hh,dy,fak1,fak2,fak3,fak4,fak5

      uint (1)=u (1)
      tint (1)=t (1)
      rint (1)=r (1)
      ruint(1)=ru(1)

      hh=0.
      do m_l=2,mmax
        hh=hh+dy
        index=2
        do j=2,dymax
          if (y(j).le.hh) then
           index=j
          endif
        enddo

        if (index.eq.dymax) then
         uint(m_l)=u(dymax)
         tint(m_l)=t(dymax)
         rint(m_l)=r(dymax)
         ruint(m_l)=ru(dymax)
        else
c         if (abs(hh-y(index+1)).lt.abs(hh-y(index)))
c     &    index=index+1
         if (index.eq.(dymax-1)) index=dymax-2
         if (index.eq.2) index=3
C        print "(a,f9.5,4es12.5)",'hh,y(i)',hh,y(index-1),y(index),
C    &            y(index+1),y(index+2)
         y1=y(index-1)
         y2=y(index  )
         y3=y(index+1)
         y4=y(index+2)
         y5=y(index-2)
         fak1=(hh-y2)*(hh-y3)*(hh-y4)*(hh-y5)/((y1-y2)*(y1-y3)*(y1-y4)
     &         *(y1-y5))
         fak2=(hh-y1)*(hh-y3)*(hh-y4)*(hh-y5)/((y2-y1)*(y2-y3)*(y2-y4)
     &         *(y2-y5))
         fak3=(hh-y1)*(hh-y2)*(hh-y4)*(hh-y5)/((y3-y1)*(y3-y2)*(y3-y4)
     &         *(y3-y5))
         fak4=(hh-y1)*(hh-y2)*(hh-y3)*(hh-y5)/((y4-y1)*(y4-y2)*(y4-y3)
     &         *(y4-y5))
         fak5=(hh-y1)*(hh-y2)*(hh-y3)*(hh-y4)/((y5-y1)*(y5-y2)*(y5-y3)
     &         *(y5-y4))
         uint(m_l)=u(index-1)*fak1+u(index)*fak2+u(index+1)*fak3+
     &           u(index+2)*fak4+u(index-2)*fak5
         tint(m_l)=t(index-1)*fak1+t(index)*fak2+t(index+1)*fak3+
     &           t(index+2)*fak4+t(index-2)*fak5
         rint(m_l)=r(index-1)*fak1+r(index)*fak2+r(index+1)*fak3+
     &           r(index+2)*fak4+r(index-2)*fak5
         ruint(m_l)=ru(index-1)*fak1+ru(index)*fak2+ru(index+1)*fak3+
     &           ru(index+2)*fak4+ru(index-2)*fak5
        endif
      enddo

c     stop 'test'

      return
      end


ATAN2(y,x) ! Arctangent(y/x), ''-pi < result <= +pi''
SINH(x)    ! Hyperbolic sine
COSH(x)    ! Hyperbolic cosine
TANH(x)    ! Hyperbolic tangent


!
!     file thwscyl.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hwscyl

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter   :: M = 50, N = 100
    integer(ip), parameter   :: IDIMF = M + 25
    integer(ip), parameter   :: MP1 = M + 1, NP1 = N + 1
    integer(ip)              :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)                 :: f(IDIMF, NP1)
    real(wp), dimension(MP1) :: bdc, bdd, r
    real(wp), dimension(NP1) :: bda, bdb, z
    real(wp)                 :: a, b, c, d, elmbda, pertrb
    real(wp), parameter      :: ZERO = 0.0_wp, ONE = 1.0_wp, FOUR = 4.0_wp

    ! Set domain and boundary conditions in r
    a = ZERO
    b = ONE
    mbdcnd = 6

    ! Set domain and boundary conditions in z
    c = ZERO
    d = ONE
    nbdcnd = 3

    ! Set helmholtz constant
    elmbda = ZERO

    ! Generate and store grid points for the purpose of computing
    ! boundary data and the right side of the poisson equation
    do i = 1, MP1
        r(i) = real(i - 1, kind=wp)/M
    end do

    do j = 1, NP1
        z(j) = real(j - 1, kind=wp)/N
    end do

    ! Generate boundary data in z. bda is a dummy variable
    bdb = FOUR * (z**4)

    ! Generate boundary data in r
    bdc = ZERO
    bdd = FOUR * (r**4)

    ! Generate right hand side of equation.
    block
        real(wp), parameter :: THREE = 3.0_wp

        do i = 1, MP1
            f(i,:NP1) = FOUR * (r(i)**2) * (z(:NP1)**2) &
                * (FOUR * (z(:NP1)**2) + THREE * (r(i)**2))
        end do
    end block

    ! Solve 2D Helmholtz in cylindrical coordiantes on centered grid
    call hwscyl(a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, bdd, &
        elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error by minimizing over all a the function
    ! norm(f(i, j) - a*1 - u(r(i), z(j))).  The exact solution is
    !
    ! u(r, z) = (r*z)**4 + arbitrary constant.
    !
    block
        real(wp), parameter :: KNOWN_PERTRB = 0.226742668667313e-3_wp
        real(wp), parameter :: KNOWN_ERROR = 0.373672238079603e-3_wp
        real(wp) :: x, discretization_error
        real(wp) :: exact_solution(MP1, NP1)

        ! Adjust solution
        x = ZERO
        do i = 1, MP1
            x = x + sum(f(i,:NP1)-(r(i)*z(:NP1))**4)
        end do
        x = x/(NP1*MP1)
        f(:MP1,:NP1) = f(:MP1,:NP1) - x

        do j = 1, NP1
            do i = 1, MP1
                exact_solution(i,j) = (r(i)*z(j))**4
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:MP1,:NP1)))

        call check_output('hwscyl', &
            ierror, KNOWN_ERROR, discretization_error, KNOWN_PERTRB, pertrb)
    end block

end program test_hwscyl


subroutine init_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi) bind(C, name="init_phi")

  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(3), hi(3), philo(3), phihi(3)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2),philo(3):phihi(3))
  real(amrex_real), intent(in   ) :: dx(3)
  real(amrex_real), intent(in   ) :: prob_lo(3)
  real(amrex_real), intent(in   ) :: prob_hi(3)

  integer          :: i,j,k
  double precision :: x,y,z,r2

  double precision :: L(3), shift(3)
  double precision :: x_p, y_p, z_p

  L = prob_hi - prob_lo
  shift = L/2.0

  do k = lo(3), hi(3)
     z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
     do j = lo(2), hi(2)
        y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
        do i = lo(1), hi(1)
           x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

           ! r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) / 0.01d0
           ! phi(i,j,k) = 1.d0 + exp(-r2)

           ! Periodic shift
           z_p = z + shift(3)
           y_p = y + shift(2)
           x_p = x + shift(1)
           if (x_p > prob_hi(1)) then
              x_p = x_p - L(1)
           endif
           if (y_p > prob_hi(2)) then
              y_p = y_p - L(2)
           endif
           if (z_p > prob_hi(3)) then
              z_p = z_p - L(3)
           endif
           r2 = ((x_p-0.0d0)**2 + (y_p-0.0d0)**2 + (z_p-0.0d0)**2) / 0.10d0
           phi(i,j,k) = 1.d0 + exp(-r2)

        end do
     end do
  end do

end subroutine init_phi


rho1 = 2.3049d-6*1.0/mbh*r**1.5d0/(alpha*cgs_kapes**3*mdot**2*f(r)**2)
T1 = 4.6189d+7*alpha**(-0.25d0)*cgs_kapes**(-0.25d0)*mbh**(-0.25d0)*r**( &
      -0.375d0)
H1 = 9.8298d+5*cgs_kapes*mbh**1.0d0*mdot*f(r)
rho2 = 21.921d0*alpha**(-0.7d0)*cgs_kapes**(-0.3d0)*mbh**(-0.7d0)*mdot** &
      0.4d0*r**(-1.65d0)*f(r)**0.4d0
T2 = 6.7232d+8*alpha**(-0.2d0)*cgs_kapes**0.2d0*mbh**(-0.2d0)*mdot** &
      0.4d0*r**(-0.9d0)*f(r)**0.4d0
H2 = 4639.5d0*alpha**(-0.1d0)*cgs_kapes**0.1d0*mbh**0.9d0*mdot**0.2d0*r &
      **1.05d0*f(r)**0.2d0
rho3 = 5.9458d+5*alpha**(-0.7d0)*kappa_abs_0**(-0.15d0)*mbh**(-0.7d0)* &
      mdot**0.55d0*r**(-1.875d0)*f(r)**0.55d0
T3 = 7.4475d+5*alpha**(-0.2d0)*kappa_abs_0**0.1d0*mbh**(-0.2d0)*mdot** &
      0.3d0*r**(-0.75d0)*f(r)**0.3d0
H3 = 154.42d0*alpha**(-0.1d0)*kappa_abs_0**0.05d0*mbh**0.9d0*mdot** &
      0.15d0*r**1.125d0*f(r)**0.15d0
r12 = 164.17d0*alpha**0.095238d0*cgs_kapes**0.85714d0*mbh**0.095238d0* &
      mdot**0.7619d0*f(r12)**0.7619d0
r23 = 5.0556d+19*cgs_kapes**1.3333d0*kappa_abs_0**(-0.66667d0)*mdot** &
      0.66667d0*f(r23)**0.66667d0