!********************************************************************************
!   MPROUTINES: Multi-Precision Routines
!   Authors: Thomas R. Cameron and Aidan O'Neill
!   Institution: Davidson College, Mathematics and Computer Science Department
!   Last Modified: 29 March 2020
!********************************************************************************
module mproutines
    use eft
    use mpmodule
    implicit none

contains
    !********************************************************
    !                  Compute Condition                    *
    !********************************************************
    ! Given the polynomial, use multi-precision Horner method
    ! to compute the condition number of poly at x. The
    ! result is returned in comp which has type real(kind=dp).
    !********************************************************
    function compCond(poly,x,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        real(kind=dp)                   :: poly(:), x
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: comp
        type(mp_real)                   :: mp_comp, mp_poly(deg+1), mp_apoly(deg+1), alpha, beta, rho

        ! convert to mp_type
        do k=1,deg+1
            mp_poly(k) = mpreald(poly(k))
            mp_apoly(k) = abs(mp_poly(k))
        end do
        ! compute rho
        mp_comp = mpreald(abs(x))
        rho = mp_apoly(deg+1)
        do k=deg,1,-1
            rho = mp_comp*rho + mp_apoly(k)
        end do
        ! compute alpha and beta
        mp_comp = mpreald(x)
        alpha = mp_poly(deg+1)
        beta = mpreald(0.0_dp)
        do k=deg,1,-1
            beta = mp_comp*beta + alpha
            alpha = mp_comp*alpha + mp_poly(k)
        end do
        ! compute cond
        if(beta==mpreald(0.0_dp)) then
            mp_comp = mpreald(big)
        else
            mp_comp = rho/abs(mp_comp*beta)
        end if
        ! convert to dp-precision
        comp = mp_comp
        return
    end function compCond
    !********************************************************
    !                  Compute Condition   Cplx             *
    !********************************************************
    ! Complex version of Compute Condition.
    !********************************************************
    function compCondCplx(poly,x,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        complex(kind=dp)                :: poly(:), x
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: comp
        type(mp_real)                   :: mp_comp, mp_apoly(deg+1), rho
        type(mp_complex)                :: cmp_comp, mp_poly(deg+1), alpha, beta

        ! convert to mp_type
        do k=1,deg+1
            mp_poly(k) = mpcmplxdc(poly(k))
            mp_apoly(k) = abs(mp_poly(k))
        end do
        ! compute rho
        mp_comp = mpreald(abs(x))
        rho = mp_apoly(deg+1)
        do k=deg,1,-1
            rho = mp_comp*rho + mp_apoly(k)
        end do
        ! compute alpha and beta
        cmp_comp = mpcmplxdc(x)
        alpha = mp_poly(deg+1)
        beta = mpcmplxdc(cmplx(0.0_dp,0.0_dp,kind=dp))
        do k=deg,1,-1
            beta = cmp_comp*beta + alpha
            alpha = cmp_comp*alpha + mp_poly(k)
        end do
        ! compute cond
        if(beta==mpcmplxdc(cmplx(0.0_dp,0.0_dp,kind=dp))) then
            mp_comp = mpreald(big)
        else
            mp_comp = rho/abs(cmp_comp*beta)
        end if
        ! convert to dp-precision
        comp = mp_comp
        return
    end function compCondCplx
    !********************************************************
    !                   limAccPoly                          *
    !********************************************************
    ! Creates test polynomial (x-1)^deg-10^(-8) for the
    ! limiting accuracy testing. The result is stored in poly.
    !********************************************************
    subroutine limAccPoly(poly,deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        real(kind=dp), intent(inout)    :: poly(:)
        ! local variables
        type(mp_real)                   :: r(deg), c(deg), alpha
        integer                         :: i, j

        ! store mp-type arrays
        do i=1,deg
            r(i) = mpreald(1.0_dp)
            c(i) = mpreald(0.0_dp)
        end do
        ! create poly
        do i=1,deg
            alpha = -r(i)
            do j=i,1,-1
                if(j==1) then
                    c(j) = c(j) + alpha
                else
                    c(j) = c(j) + alpha*c(j-1)
                end if
            end do
        end do
        ! shift c(deg) by 10E-8
        c(deg) = c(deg) - mpreald(1.0E-8_dp)
        ! convert to dp-precision
        do i=1,deg
            poly(i) = c(deg+1-i)
        end do
        poly(deg+1) = 1.0_dp
    end subroutine limAccPoly
    !********************************************************
    !                   limAccPolyCplx                      *
    !********************************************************
    ! Complex version of limAccPoly.
    !********************************************************
    subroutine limAccPolyCplx(poly,deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(inout) :: poly(:)
        ! local variables
        type(mp_complex)                :: r(deg), c(deg), alpha
        integer                         :: i, j

        ! store mp-type arrays
        do i=1,deg
            r(i) = mpcmplxdc(cmplx(1.0_dp,1.0_dp,kind=dp))
            c(i) = mpcmplxdc(cmplx(0.0_dp,0.0_dp,kind=dp))
        end do
        ! create poly
        do i=1,deg
            alpha = -r(i)
            do j=i,1,-1
                if(j==1) then
                    c(j) = c(j) + alpha
                else
                    c(j) = c(j) + alpha*c(j-1)
                end if
            end do
        end do
        ! shift c(deg) by 10E-8
        c(deg) = c(deg) - mpcmplxdc(cmplx(1.0E-8_dp,0.0_dp,kind=dp))
        ! convert to dp-precision
        do i=1,deg
            poly(i) = c(deg+1-i)
        end do
        poly(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
    end subroutine limAccPolyCplx
    !********************************************************
    !                   limAccRoot                          *
    !********************************************************
    ! Given coeeficients of (x-1)^deg-10^(-8) stored in
    ! dp-precision, use multi-precision Newton's method to
    ! compute exact root. The result is returned in comp which
    ! has type real(kind=dp).
    !********************************************************
    function limAccRoot(poly,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        real(kind=dp)                   :: poly(:)
        ! local variables
        integer                         :: j, k
        real(kind=dp)                   :: comp
        type(mp_real)                   :: mp_comp, mp_poly(deg+1), alpha, beta

        ! convert to mp-type
        do k=1,deg+1
            mp_poly(k) = mpreald(poly(k))
        end do
        ! root approximation
        mp_comp = mpreald(1.0_dp + 10.0_dp**(-8.0_dp/real(deg,kind=dp)))
        ! Newton's method
        do k=1,5
            ! MPHorner applied to mp_mpoly
            alpha = mp_poly(deg+1)
            beta = mpreald(0.0_dp)
            do j=deg,1,-1
                beta = mp_comp*beta + alpha
                alpha = mp_comp*alpha + mp_poly(j)
            end do
            ! update root approximation
            mp_comp = mp_comp - (alpha/beta)
        end do
        ! convert to dp-precision
        comp = mp_comp
        return
    end function limAccRoot
    !********************************************************
    !                   limAccRootCplx                      *
    !********************************************************
    ! Complex version of limAccRoot.
    !********************************************************
    function limAccRootCplx(poly,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        complex(kind=dp)                :: poly(:)
        ! local variables
        integer                         :: j, k
        complex(kind=dp)                :: comp
        type(mp_complex)                :: mp_comp, mp_poly(deg+1), alpha, beta

        ! convert to mp-type
        do k=1,deg+1
            mp_poly(k) = mpcmplxdc(poly(k))
        end do
        ! root approximation
        mp_comp = mpcmplxdc(cmplx(1.0_dp + 10.0_dp**(-8.0_dp/real(deg,kind=dp)),1.0_dp,kind=dp))
        ! Newton's method
        do k=1,5
            ! MPHorner applied to mp_mpoly
            alpha = mp_poly(deg+1)
            beta = mpcmplxdc(cmplx(0.0_dp,0.0_dp,kind=dp))
            do j=deg,1,-1
                beta = mp_comp*beta + alpha
                alpha = mp_comp*alpha + mp_poly(j)
            end do
            ! update root approximation
            mp_comp = mp_comp - (alpha/beta)
        end do
        ! convert to dp-precision
        comp = mp_comp
        return
    end function limAccRootCplx
    !********************************************************
    !                   Multi-precision Horner              *
    !********************************************************
    ! Evaluate polynomial at floating-point number in multi-
    ! precision using MPFun and Horner's method. The result
    ! is returned in comp which has type real(kind=dp).
    !********************************************************
    function MPHorner(poly,x,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        real(kind=dp)                   :: poly(:), x
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: comp
        type(mp_real)                   :: mp_comp, mp_poly(deg+1), mp_x

        ! convert to mp-type
        do k=1,deg+1
            mp_poly(k) = mpreald(poly(k))
        end do
        mp_x = mpreald(x)
        ! Horner's method
        mp_comp = mp_poly(deg+1)
        do k=deg,1,-1
            mp_comp = mp_x*mp_comp + mp_poly(k)
        end do
        ! convert to dp-precision
        comp = mp_comp
        return
    end function MPHorner
    !********************************************************
    !                   Multi-precision Horner Cplx         *
    !********************************************************
    ! Complex version of MPHorner.
    !********************************************************
    function MPHornerCplx(poly,x,deg) result(comp)
        implicit none
        ! argument variables
        integer                         :: deg
        complex(kind=dp)                :: poly(:), x
        ! local variables
        integer                         :: k
        complex(kind=dp)                :: comp
        type(mp_complex)                :: mp_comp, mp_poly(deg+1), mp_x

        ! convert to mp-type
        do k=1,deg+1
            mp_poly(k) = mpcmplxdc(poly(k))
        end do
        mp_x = mpcmplxdc(x)
        ! Horner's method
        mp_comp = mp_poly(deg+1)
        do k=deg,1,-1
            mp_comp = mp_x*mp_comp + mp_poly(k)
        end do
        ! convert to dp-precision
        comp = mp_comp
        return
    end function MPHornerCplx
    !********************************************************
    !                   Roots to Coeffs                     *
    !********************************************************
    ! Uses mpfun to compute the coefficients of a polynomial
    ! whose roots are given in roots. The result is stored
    ! in coeffs.
    !********************************************************
    subroutine rootCoeff(deg,roots,coeffs)
        implicit none
        ! argument variables
        integer, intent(in)           :: deg
        real(kind=dp), intent(in)     :: roots(:)
        real(kind=dp), intent(out)    :: coeffs(:)
        ! local variables
        type(mp_real)                 :: r(deg), c(deg+1), alpha
        integer                       :: i, j

        ! convert to mp-type
        do i=1,deg
            r(i) = mpreald(roots(i))
            c(i) = mpreald(0.0_dp)
        end do
		! expand polynomial
        do i=1,deg
            alpha = -r(i)
            do j=i,1,-1
                if(j==1) then
                    c(j) = c(j) + alpha
                else
                    c(j) = c(j) + alpha*c(j-1)
                end if
            end do
        end do
        ! convert to dp-precision
        do i=1,deg
            coeffs(i) = c(deg+1-i)
        end do
        ! multiply by leading coefficient
        do i=1,deg
            coeffs(i) = coeffs(deg+1)*coeffs(i)
        end do
    end subroutine rootCoeff
    !********************************************************
    !                   Roots to Coeffs Cplx                *
    !********************************************************
    ! Complex version of rootCoeff.
    !********************************************************
    subroutine rootCoeffCplx(deg,roots,coeffs)
        implicit none
        ! argument variables
        integer, intent(in)           :: deg
        complex(kind=dp), intent(in)  :: roots(:)
        complex(kind=dp), intent(out) :: coeffs(:)
        ! local variables
        type(mp_complex)              :: r(deg), c(deg+1), alpha
        integer                       :: i, j

        ! convert to mp-type
        do i=1,deg
            r(i) = mpcmplxdc(roots(i))
            c(i) = mpcmplxdc(cmplx(0.0_dp,0.0_dp,kind=dp))
        end do
		! expand polynomial
        do i=1,deg
            alpha = -r(i)
            do j=i,1,-1
                if(j==1) then
                    c(j) = c(j) + alpha
                else
                    c(j) = c(j) + alpha*c(j-1)
                end if
            end do
        end do
        ! convert to dp-precision
        do i=1,deg
            coeffs(i) = c(deg+1-i)
        end do
        ! multiply by leading coefficient
        do i=1,deg
            coeffs(i) = coeffs(deg+1)*coeffs(i)
        end do
    end subroutine rootCoeffCplx
end module mproutines


Function fnndpi(s)
  Parameter (srt0=2.012)
  If (s<=srt0**2) Then
    fnndpi = 0.
  Else
    fnndpi = 26.*exp(-(s-4.65)**2/0.1) + 4.*exp(-(s-4.65)**2/2.) + 0.28*exp(-(s-6.)**2/10.)
  End If
  Return
End Function fnndpi


c=======================================================================
c
c     subroutine pricing/PRvanilla
c
c     This function computes analytic valuation and greeks for European
c     style puts and calls (Vanilla) allows different daycount and interest
c     rate conventions.
c
c     List of Results (Greeks)
c     ------------------------
c     0 :value
c     1 :spot delta
c     2 :gamma
c     3 :annual theta
c     4 :vega
c     5 :rho domestic
c     6 :rho foreign
c     7 :dstrike                 !derivative wrt strike
c     8 :d2strike                !second derivative wrt strike
c     9 :dduration               !derivative wrt to T(time to expiration) = - annual theta
c     10:leverage                !spot * spotdelta / value
c     11:vomma                   !second derivative wrt vol
c     12:retrieved_vola          !volatility implied by the option value, enter value for vol
c     13:forwarddelta            !derivative wrt forward
c     14:probdelta               !common probability factor in spot delta and forward delta, N(d1)
c     15:daily theta
c     16:forward
c     17:swaprate
c     18:d1
c     19:d2
c     20:disc                    !domestic discount factor
c     21:strike_of_delta
c
c-----------------------------------------------------------------------
      SUBROUTINE PRvanilla(spot, strike, vol, rd, rf, tau, phi,
     &                     convention, quotation, greek, van, info)
c-----------------------------------------------------------------------
c
c INPUT
c   spot   : spot price (>0)                                      double
c   strike : stike price (>0)                                     double
c   vol    : annual volatility (>=0)                              double
c   rd     : domestic risk free rate (>=0)                        double
c            discounting is done as (1+r)^{-T}\n
c   rf     : foreign risk free rate or dividend rate (>=0)        double
c            discounting is done as (1+rf)^{-T}\n
c   tau    : time to maturity (in year)                           double
c   phi    : (1) Call, (-1) Put                                  integer
c   convention : compounded convention                           integer
c                (0) linear for less than one year,
c                (1) annually compounded,
c                (2) continuously compounded
c   quotation  : system of quotation                             integer
c                (0) domestic,
c                (1) %domestic,
c                (2) foreign,
c                (3) %foreign
c   greek      : type of result                                  integer
c     (0) :value
c     (1) :spot delta, first derivative of the option value with respect to the underlying price
c     (2) :gamma, second derivative of the option value with respect to the underlying price
c     (3) :annual theta, derivative of the option value with respect to the amount of time to expiry
c     (4) :vega, derivative of the option value with respect to the volatility of the underlying
c     (5) :rho domestic, derivative of the option value with respect to the risk free rate
c     (6) :rho foreign
c     (7) :dstrike, derivative wrt strike
c     (8) :d2strike, second derivative wrt strike
c     (9) :dduration, derivative wrt to T(time to expiration) = - annual theta
c     (10):leverage, spot * spotdelta / value
c     (11):vomma/volga, second derivative wrt vol (second derivative of the option value with respect to the volatility of the underlying)
c     (12):retrieved_vola, volatility implied by the option value, enter value for vol
c     (13):forwarddelta, derivative wrt forward
c     (14):probdelta, common probability factor in spot delta and forward delta, N(d1)
c     (15):daily theta
c     (16):forward
c     (17):swaprate
c     (18):d1
c     (19):d2
c     (20):disc, domestic discount factor
c     (21):strike_of_delta
c
c OUTPUT
c   van        : result of analytics                             double
c   info       : diagnostic argument                            integer
c
c----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER phi, convention, quotation, greek, info
      DOUBLE PRECISION spot, strike, vol, rd, rf, tau, van
c
c     external functions
      DOUBLE PRECISION PRVAN
      EXTERNAL PRVAN
c
c----------------------------------------------------------------------
c
c     initialization
      info = 0
      van  = 0
c
c     PRVAN (Analytics Vanilla), cf. pricing/PRutils.F
      van = PRVAN(spot, strike, vol, rd ,rf ,tau ,phi ,convention,
     &             quotation, greek)
c
      RETURN
      END


      subroutine clawpack46_rpt2(ixy,maxm,meqn,mwaves,mbc,mx,ql,qr,
     &      aux1,aux2,aux3,imp,asdq,bmasdq,bpasdq)
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for the acoustics equations
c     # with varying material properties rho and kappa
c
c     # auxN(i,1) holds rho
c     # auxN(i,2) holds c
c     #  N = 1 for row below
c     #      2 for this row
c     #      3 for row above
c
c     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.
c
c     # imp=1  means  asdq=amdq,    imp=2 means asdq=apdq
c
      dimension    ql(1-mbc:maxm+mbc, meqn)
      dimension    qr(1-mbc:maxm+mbc, meqn)
      dimension    asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
      dimension   aux1(1-mbc:maxm+mbc, *)
      dimension   aux2(1-mbc:maxm+mbc, *)
      dimension   aux3(1-mbc:maxm+mbc, *)
c
c
c
      if (ixy.eq.1) then
          mu = 2
          mv = 3
        else
          mu = 3
          mv = 2
        endif
c
c
      do 20 i = 2-mbc, mx+mbc
c
c        # imp is used to flag whether wave is going to left or right,
c        # since material properties are different on the two sides
c
         if (imp.eq.1) then
c            # asdq = amdq, moving to left
             i1 = i-1
           else
c            # asdq = apdq, moving to right
             i1 = i
           endif
c
c        # The flux difference asdq is split into downward moving part
c        # traveling at speed -c relative to the medium below and
c        # an upward moving part traveling
c        # at speed +c relative to the medium above.
c
c        # Note that the sum of these parts does not give all of asdq
c        # since there is also reflection at the interfaces which decreases
c        # the flux.
c
c        # sound speed in each row of cells:
         cm = aux1(i1,2)
         c = aux2(i1,2)
         cp = aux3(i1,2)
c
c        # impedances:
         zm = aux1(i1,1)*aux1(i1,2)
         zz = aux2(i1,1)*aux2(i1,2)
         zp = aux3(i1,1)*aux3(i1,2)

c        # transmitted part of down-going wave:
         a1 = (-asdq(i,1) + asdq(i,mv)*zz) /
     &         (zm + zz)

c        # transmitted part of up-going wave:
         a2 = (asdq(i,1) + asdq(i,mv)*zz) /
     &         (zz + zp)
c
c        # The down-going flux difference bmasdq is the product  -c * wave
c
         bmasdq(i,1) = cm * a1*zm
         bmasdq(i,mu) = 0.d0
         bmasdq(i,mv) = -cm * a1
c
c        # The up-going flux difference bpasdq is the product  c * wave
c
         bpasdq(i,1) = cp * a2*zp
         bpasdq(i,mu) = 0.d0
         bpasdq(i,mv) = cp * a2
c
   20    continue
c
      return
      end


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!    a program testing subroutines shpgi and shpg
!
!    shpg is the n**2 projection with complement, odd/even
!    factorization and zero truncation on a Gaussian distributed
!    grid. The projection is defined in the JCP paper "Generalized
!    discrete spherical harmonic transforms" by
!    Paul N. Swarztrauber and William F. Spotz
!    J. Comp. Phys., 159(2000) pp. 213-230.
!
!                     April 2002
!
program tshpg

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: discretization_error
    real(wp) :: g
    real(wp) :: ga
    real(wp) :: gb
    real(wp) :: gh
    integer(ip) :: i
    integer(ip) :: idimg
    integer(ip) :: idp
    integer(ip) :: ierror
    integer(ip) :: iprint
    integer(ip) :: isym
    integer(ip) :: iwshp
    integer(ip) :: j
    integer(ip) :: jdimg
    integer(ip) :: kdp
    integer(ip) :: liwshp
    integer(ip) :: lwork
    integer(ip) :: lwrk
    integer(ip) :: lwrk1
    integer(ip) :: lwsha
    integer(ip) :: lwshp
    integer(ip) :: lwshs
    integer(ip) :: mode
    integer(ip) :: mp1
    integer(ip) :: mtr
    integer(ip) :: mtrunc
    integer(ip) :: nlat
    integer(ip) :: nlon
    integer(ip) :: np1
    integer(ip) :: nt
    real(wp) :: sx
    real(wp) :: sy

    real(wp) :: toe
    real(wp) :: tusl
    real(wp) :: wrk1
    real(wp) :: wrk2
    real(wp) :: wshagc
    real(wp) :: wshp
    real(wp) :: wshsgc
    parameter (idp=8)
    parameter (kdp=idp+idp-2)
    parameter (lwshp=2*(idp+1)**2+kdp+20, &
        liwshp=4*(idp+1), lwrk=1.25*(idp+1)**2+7*idp+8)
    parameter (lwrk1=idp*kdp)
    parameter(lwork = 4*idp*(idp-1), &
        lwsha=idp*(4*idp+1)+idp+idp+15)
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp) :: work(lwrk)
    dimension sx(idp, kdp), sy(idp, kdp), &
        wshp(lwshp), iwshp(liwshp), wrk1(lwrk1)
    dimension g(idp, kdp, 2), ga(idp, idp, 2), gb(idp, idp, 2), &
        gh(idp, kdp, 2), &
        wrk2(lwork), wshagc(lwsha), wshsgc(lwsha)

    iprint = 0
    nt = 1
    isym = 0
    mode = 0

    do nlat=6, 8
        do mtr=1, 2
            nlon = 2*(nlat-1)
            mtrunc = nlat-mtr
            mtrunc = min(mtrunc, nlat-1, nlon/2)
            idimg = idp
            jdimg = kdp
            call shagci(nlat, nlon, wshagc, ierror)
            call check_error(ierror)

            lwshs = lwsha
            call shsgci(nlat, nlon, wshsgc, ierror)
            call check_error(ierror)

            ! Initiate faster filter
            call shpgi(nlat, nlon, isym, mtrunc, wshp, lwshp, iwshp, liwshp, &
                work, lwrk, ierror)
            call check_error(ierror)

            if (iprint /= 0) write (stdout, '(3(a, i5))') &
                ' mode =' , nlon, '  nlat =', nlat, '  nlon =', nlon

            ! Initialize with pseudo random field
            do i=1, nlat
                do j=1, nlon
                    sx(i, j) =  cos(real(i*j, kind=wp))
                    g(i, j, 1) = sx(i, j)
                end do
            end do

            call shagc(nlat, nlon, mode, nt, g, idimg, jdimg, ga, gb, idimg, idimg, &
                wshagc, ierror)
            call check_error(ierror)

            if(mtrunc < nlat-1) then
                do np1=mtrunc+2, nlat
                    do mp1=1, np1
                        ga(mp1, np1, 1) = ZERO
                        gb(mp1, np1, 1) = ZERO
                    end do
                end do
            end if

            call shsgc(nlat, nlon, mode, nt, gh, idimg, jdimg, ga, gb, idimg, idimg, wshsgc, ierror)
            call check_error(ierror)

            call shpg(nlat, nlon, isym, mtrunc, sx, sy, idp, &
                wshp, lwshp, iwshp, liwshp, wrk1, lwrk1, ierror)
            call check_error(ierror)

            if (iprint > 0) write (stdout, '(/a/)') ' approx and exact solution'

            do j=1, nlon
                if(iprint > 0) write (stdout, 437) j, (sy(i, j), gh(i, j, 1), i=1, nlat)
437             format(' j=', i5, 1p4e15.6/(8x, 1p4e15.6))
            end do

            discretization_error = maxval(abs(sy(:nlat, :nlon)-gh(:nlat, :nlon, 1)))

            write (stdout, '(/2(a, i5)/)') &
                'case nlat =', nlat, ' and mtrunc =', mtrunc

            write (stdout, '(3(a, 1pe15.6/))') &
                ' error =', discretization_error, &
                ' tusl  =', tusl, &
                ' toe   =', toe
        end do
    end do
end program tshpg


***************************************************************************

!                           CHIME model
! Simulates Susceptible, Infected, Recovered Population by taking into
! account SIR model parameters as long as hospitalization parameters and
! policy initiatives

****************************************************************************
!       Policy Module

!       State Variables:
!       beta       Rate  of transmission via contact
!       num_days   Number of  days over which a certain policy is active
****************************************************************************
      module PolicyMod
        implicit none
        type Policy
          real beta
          integer num_days

        end type Policy
      end module PolicyMod

*****************************************************************************
!       Subroutine to calculate beta of SIR model from intrinsic growth rate,
!       gamma (1/infectious days), relative contact rate (social distancing
!       parameter)
!
!       Input Variables:
!       intrinsic_growth_rate     Rate at which rate of infection  is growing
!       gamma                     Rate of recovery  from infection
!       susceptible               Size of Susceptible Population
!       relative_contact_rate     Contact rate between members of susceptible and infected groups
!
!       Local Variables:
!       inv_contact_rate          Complement of relative_contact_rate
!       updated_growth_rate       modified growth rate
!
!       Output  Variable:
!       beta                      Rate  of transmission  via contact
*****************************************************************************
      subroutine get_beta(intrinsic_growth_rate, gamma,
     &                    susceptible, relative_contact_rate,
     &                    beta)
        real intrinsic_growth_rate, susceptible
     &       relative_contact_rate, gamma
        real inv_contact_rate, updated_growth_rate
        real  beta

        inv_contact_rate = 1.0 - relative_contact_rate
        updated_growth_rate = intrinsic_growth_rate + gamma
        beta = updated_growth_rate / susceptible * inv_contact_rate

      end subroutine get_beta

*****************************************************************************
!       Subroutine to calculate intrinsic growth rate necessary for
!       calculating beta from doubling time (doubling_time) as the input
!       parameter
!
!       Input Variable:
!       doubling_time       Time taken for the  number of infected people to  double
!
!       Output Variable:
!       growth_rate         Intrinsic  growth rate
****************************************************************************

      subroutine get_growth_rate(doubling_time,
     &  growth_rate)

        real doubling_time
        real growth_rate

        if (doubling_time .eq. 0.0) then
            growth_rate = 0.0
        else
          growth_rate = 2.0 ** (1.0 / doubling_time) - 1.0
        endif

      end subroutine get_growth_rate

*****************************************************************************
!       Subroutine to calculate susceptible (s), infected (i), and recovered (r)
!       group of people in one day. The populations are normaized based
!       on a scaling factor (scale) from beta, gamma parameters
!
!       Input Variables:
!       beta        Rate of transmission via contact
!       gamma       Rate of recovery from infection
!       n           Total number of members (s+i+r)
!       s           Amount of susceptble members at previous timestep
!       i           Amount of infected members at previous timestep
!       r           Amount of recovered members at current timestep
!
!       State Variables:
!       s_n         Amount of susceptible members at current timestep
!       i_n         Amount of infected members at current timestep
!       r_n         Amount of recovered members at current timestep
!       scale       scaling factor
*****************************************************************************

      subroutine sir(beta, gamma, n,
     &                s, i, r)

        real  beta, gamma, n
        real s, i, r
        real s_n, i_n, r_n, scale

        ! Calculate current day's susceptible (s_n), infected (i_n),
        ! recovered (r_n) populations from  previous day's populations
        ! using SIR model
        s_n = (-beta * s * i) + s
        i_n = (beta * s * i - gamma * i) + i
        r_n = gamma * i + r

        ! Calculate scaling factor
        scale = n / (s_n + i_n + r_n)

        ! Scale s, i, r populations
        s = s_n * scale
        i = i_n * scale
        r = r_n * scale

      end subroutine sir

*****************************************************************************
!       Subroutine to simulate susceptible (s), infected (i), and recovered (r)
!       group of people over the total number of days spanning over all policies
!
!       Input Variables:
!       s_n         Amount of susceptible members at current timestep
!       i_n         Amount of infected members at current timestep
!       r_n         Amount of recovered members at current timestep
!       gamma       Rate of recovery from infection
!       i_day       Index of day beyond which SIR  model is simulated
!       N_p         Number  of policies
!       N_t         Total number of days over which  policies are active
!       policy      list of policies containing both beta and number of  days over
!                   which a particular  policy is active
!
!       Local Variables:
!       n           Total population
!       beta        Rate of  transmission via contact
!       N_d         Number  of days in each policy
!       d           Day Index
!       idx         Counter over arrays
!       p_idx       Counter over policies
!       d_idx       Counter over  N_d
!
!       Output  Variables:
!       T           Array for storing indices of total number  of days
!       S           Array  for  storing amount of susceptible members on a  particular day
!                   over all sets  of policies
!       I           Array  for  storing amount of infected members on a  particular day
!                   over all sets  of policies
!       R           Array  for  storing amount of recovered members on a  particular day
!                   over all sets  of policies
!       E           Arrau for  storing amount of  members to have ever been infected on a
!                   particular day over all  policies
*****************************************************************************
      subroutine sim_sir(s_n, i_n, r_n, gamma, i_day, N_p,
     &                    N_t, policies,
     &                    T, S, E,  I, R)
        use PolicyMod

        real s_n, i_n, r_n, gamma
        integer i_day,  N_p, N_t
        type (Policy) policies(N_p)
        real n, beta
        integer d, idx, p_idx, d_idx, N_d
        integer T(N_t+1)
        real S(N_t+1), E(N_t+1), I(N_t+1), R(N_t+1)

        n = s_n + i_n + r_n
        d = i_day

        idx = 1
        do p_idx = 1, N_p
          beta = policies(p_idx) % beta
          N_d = policies(p_idx) % num_days
          do d_idx = 1, N_d
            T(idx) = d
            S(idx) = s_n
            I(idx) = i_n
            R(idx) = r_n
            E(idx) = i_n + r_n
            idx = idx + 1
            call sir(beta, gamma, n, s_n, i_n, r_n)
            d = d + 1
          enddo
        enddo

        T(idx) = d
        S(idx) = s_n
        I(idx) = i_n
        R(idx) = r_n
        E(idx) = i_n + r_n

      end subroutine sim_sir

      program main
        use PolicyMod
        implicit none
        real s_n, i_n, r_n, beta, doubling_time, growth_rate
        integer p_idx
        integer, parameter :: i_day = 0, n_days = 20
        integer, parameter :: N_p = 2, infectious_days = 14
        real, parameter :: relative_contact_rate = 0.05
        real, parameter :: gamma = 1.0 / infectious_days
        type (Policy), dimension(1:N_p) :: policies
        integer N_t
        integer, dimension(:), allocatable :: T
        real, dimension(:), allocatable :: S, E, I, R

        s_n = 1000
        i_n = 0
        r_n = 0

        N_t = 0
        do p_idx = 1, N_p
          doubling_time = p_idx * 5.0
          call get_growth_rate(doubling_time, growth_rate)
          call get_beta(growth_rate, gamma, s_n,
     &                  relative_contact_rate, beta)
          policies(p_idx) % beta = beta
          policies(p_idx) % num_days = n_days * p_idx
          N_t = N_t + policies(p_idx) % num_days
        end do

        allocate(T(N_t+1)); allocate(S(N_t+1)); allocate(E(N_t+1));
        allocate(I(N_t+1)); allocate(R(N_t+1));

        call sim_sir(s_n, i_n, r_n, gamma, i_day, N_p, N_t, policies,
     &                  T, S, E, I, R)
      end program main


c Version 1.3.2
c----------------------------------------------------------------------
c                    =========================
c                       subroutine GCONVL
c                    =========================
c
c     Convolute given real-valued spectrum with a Gaussian lineshape
c     having a specified derivative peak-to-peak linewidth.
c
c     NOTE: this differs from EPRLL version, which transforms a
c     complex-valued spectrum.
c
c----------------------------------------------------------------------
      subroutine gconvl( spectr,wline,dfld,nfld,nft, tmpdat)
!f2py intent(in) spectr
!f2py intent(in) wline
!f2py intent(in) dfld
!f2py intent(in) nfld
!f2py intent(in) nft
!f2py intent(out) tmpdat

      implicit none
c
      integer nfld,nft
c
      integer i,k,no2
      double precision df,f,g,gnorm
c
c      include 'nlsdim.inc'
c      include 'ftwork.inc'
c      include 'pidef.inc'
c
      double precision EIGHT,EPS,ONE,TWO,THIRD,ZERO
      double precision PI,RADIAN
      integer MXPT
      parameter ( EIGHT=8.0D0,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0,
     #            EPS=1.0D-6,THIRD=0.33333333333333D0 )
      parameter (PI=3.1415926535897932384D0,RADIAN=PI/180.0D0)
      parameter (MXPT=4096)
      double precision tmpdat(MXPT)
      double precision spectr(MXPT),wline,dfld
c
c######################################################################
c
      if (wline.lt.EPS) return
c
c     -----------------------------------------------
c     Store calculation in tmpdat, zero-pad, and FFT
c     -----------------------------------------------
      do i=1,nfld
         tmpdat(i)=spectr(i)
      end do
c
      do i=nfld+1,nft
         tmpdat(i)=ZERO
      end do
c
      no2=nft/2
      call realft( tmpdat,no2,+1 )
c
c     ------------------------------------------------------------
c     Convolute with Gaussian function by multiplying in
c     with a Gaussian in Fourier space.
c
c     NOTE: REALFT returns only the positive frequencies
c     since FT of a real function is symmetric. Also, the
c     first and last elements of the FT array are real-valued
c     and returned as the real and imaginary parts of tmpdat(1)
c     ------------------------------------------------------------
      df=TWO*PI/(nft*dfld)
      gnorm=ONE/dfloat(no2)
      tmpdat(1)=tmpdat(1)*gnorm
      tmpdat(2)=tmpdat(2)*gnorm*dexp(-(no2*df*wline)**2/EIGHT)
      f=df
      do i=3,nft,2
         g=gnorm*dexp( -(f*wline)**2/EIGHT )
         tmpdat(i)=tmpdat(i)*g
         tmpdat(i+1)=tmpdat(i+1)*g
         f=f+df
      end do
c
c     ------------------------------------------------------------
c     Back-transfor to obtain convoluted spectrum and restore in
c     spectr array
c     ------------------------------------------------------------
      call realft( tmpdat,no2,-1 )
c no need, as tmpdat is my output now
c      do i=1,nfld
c         spectr(i)=tmpdat(i)
c      end do
c
      return
      end

      subroutine realft(data,n,isign)
      implicit none
      integer i,i1,i2,i3,i4,isign,n,n2p3
      double precision c1,c2,h1r,h1i,h2r,h2i,wrs,wis,wr,wi,wpr,wpi,
     #                 wtemp,theta
      double precision data(2*n)
c
      theta=6.28318530717959d0/2.0d0/dble(n)
      c1=0.5d0
      if (isign.eq.1) then
        c2=-0.5d0
        call four1(data,n,+1)
      else
        c2=0.5d0
        theta=-theta
      endif
      wpr=-2.0d0*dsin(0.5d0*theta)**2
      wpi=dsin(theta)
      wr=1.d0+wpr
      wi=wpi
      n2p3=2*n+3
      do 11 i=2,n/2+1
        i1=2*i-1
        i2=i1+1
        i3=n2p3-i2
        i4=i3+1
        wrs=sngl(wr)
        wis=sngl(wi)
        h1r=c1*(data(i1)+data(i3))
        h1i=c1*(data(i2)-data(i4))
        h2r=-c2*(data(i2)+data(i4))
        h2i=c2*(data(i1)-data(i3))
        data(i1)=h1r+wrs*h2r-wis*h2i
        data(i2)=h1i+wrs*h2i+wis*h2r
        data(i3)=h1r-wrs*h2r+wis*h2i
        data(i4)=-h1i+wrs*h2i+wis*h2r
        wtemp=wr
        wr=wr*wpr-wi*wpi+wr
        wi=wi*wpr+wtemp*wpi+wi
11    continue
      if (isign.eq.1) then
        h1r=data(1)
        data(1)=h1r+data(2)
        data(2)=h1r-data(2)
      else
        h1r=data(1)
        data(1)=c1*(h1r+data(2))
        data(2)=c1*(h1r-data(2))
        call four1(data,n,-1)
      endif
      return
      end

      subroutine four1(data,nn,isign)
      implicit none
      integer i,istep,j,m,mmax,n,nn,isign
      double precision wr,wi,wpr,wpi,wtemp,tempi,tempr,theta
      double precision data(2*nn)
c
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        go to 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*dsin(0.5d0*theta)**2
        wpi=dsin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      go to 2
      endif
      return
      end


module local_routines
    !!
    !! Simulate wave motion in a paraboloid bowl, which has an analytical solution
    !!
    use global_mod, only: dp, ip
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use read_raster_mod, only: multi_raster_type
    use logging_mod, only: log_output_unit
    implicit none

    contains

    subroutine set_initial_conditions_paraboloid_bowl(domain)
        class(domain_type), target, intent(inout):: domain
        integer(ip):: i, j
        real(dp) :: x, y, L, D, r0, r, A

        r0 = 2000.0_dp
        L = 2500.0_dp
        D = 1000.0_dp
        A = (L**4 - r0**4)/(r0**4 + L**4)

        ! Set stage and elevation
        ! This saves memory compared to doing it all at once.
        do j = 1, domain%nx(2)
            y = domain%y(j)
            do i = 1, domain%nx(1)
                x = domain%x(i)

                r = sqrt(x*x + y*y)
                ! Bed elevation
                domain%U(i,j,ELV) = D*(r*r/(L*L) - 1.0_dp)
                ! Stage
                domain%U(i,j,STG) = D*( &
                    (sqrt(1.0_dp-A*A))/(1.0_dp - A) &
                    -1.0_dp - r*r/(L*L)*((1.0_dp - A*A)/((1.0_dp - A)**2) - 1.0_dp) &
                    )
            end do
        end do

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV) + 1.0e-07_dp)

        write(log_output_unit,*) 'Stage range is: ', minval(domain%U(:,:,STG)), maxval(domain%U(:,:,STG))
        write(log_output_unit,*) 'Elev range is: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

        if(domain%timestepping_method == 'cliffs') then
            domain%cliffs_minimum_allowed_depth = 5_dp
        end if

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program run_paraboloid_basin
    !!
    !! Simulate wave motion in a paraboloid bowl, which has an analytical solution
    !!

    use global_mod, only: ip, dp, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type
    use timer_mod, only: timer_type
    use logging_mod, only: log_output_unit, send_log_output_to_file
    use stop_mod, only: generic_stop
#ifdef COARRAY_PROVIDE_CO_ROUTINES
    use coarray_intrinsic_alternatives, only: co_min
#endif
    use coarray_intrinsic_alternatives, only: swals_mpi_init, swals_mpi_finalize
    use local_routines

    implicit none

    ! Type holding all domains
    type(multidomain_type) :: md

    ! Local timing object
    type(timer_type) :: program_timer

    ! Change this to decrease the cell size by mesh_refine (i.e. for convergence testing)
    integer(ip), parameter :: mesh_refine = 4_ip

    ! The global (i.e. outer-domain) time-step in the multidomain
    real(dp) ::  global_dt ! = (0.23_dp/mesh_refine) * 1.0_dp

    ! Approx timestep between outputs
    real(dp) :: approximate_writeout_frequency = 1.0_dp
    real(dp) :: final_time = 300.0_dp * 1.0_dp

    ! Length/width
    real(dp), parameter, dimension(2):: global_lw = 8000.0_dp * [1.0_dp, 1.0_dp]
    ! Lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = -global_lw/2.0_dp
    ! grid size (number of x/y cells)
    integer(ip), parameter, dimension(2):: global_nx = [100, 100]*mesh_refine + 1

    ! Useful misc variables
    integer(ip):: nd, j

    call swals_mpi_init
    call program_timer%timer_start('setup')

#ifdef SPHERICAL
    write(log_output_unit,*) 'Code assumes cartesian oordinates, but SPHERICAL is defined'
    call generic_stop
#endif

    ! nd domains in this model
    nd = 1
    allocate(md%domains(nd))

    !
    ! Setup basic metadata
    !

    ! Linear domain
    md%domains(1)%lw = global_lw
    md%domains(1)%lower_left =global_ll
    md%domains(1)%nx = global_nx
    md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
    md%domains(1)%dx_refinement_factor = 1.0_dp
    md%domains(1)%timestepping_refinement_factor = 1_ip
    md%domains(1)%timestepping_method = default_nonlinear_timestepping_method

    !@ Splitting the domain the same way, irrespective of np, improves reproducibility
    ! md%load_balance_file = 'load_balance_partition.txt'
    call get_command_argument(1, md%load_balance_file)

    ! Allocate domains and prepare comms
    call md%setup(extra_halo_buffer=0_ip)

    ! Set initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions_paraboloid_bowl(md%domains(j))
    end do
    call md%make_initial_conditions_consistent()

    ! NOTE: For stability in 'null' regions, we set them to 'high land' that
    ! should be inactive.
    call md%set_null_regions_to_dry()

    write(log_output_unit,*) 'End setup'

    ! Print the gravity-wave CFL limit, to guide timestepping
    do j = 1, size(md%domains)
        write(log_output_unit,*) 'domain: ', j, 'ts: ', &
            md%domains(j)%stationary_timestep_max()
    end do
    global_dt = md%stationary_timestep_max()

    call program_timer%timer_end('setup')
    call program_timer%timer_start('evolve')

#ifdef COARRAY
    ! Get the minimum global_dt
    call co_min(global_dt)
#endif
    flush(log_output_unit)

    ! The water will rise (and fall) in the deepest area so we need a timestep
    ! somewhat smaller than the initial stationary timestep. From experience
    ! this timestep is stable
    global_dt = 0.71_dp * global_dt * md%domains(1)%cfl ! * 1.0_dp/3.0_dp

    !
    ! Evolve the code
    !

    do while (.true.)

        ! IO
        call program_timer%timer_start('IO')
        call md%write_outputs_and_print_statistics(&
            approximate_writeout_frequency = approximate_writeout_frequency)
        call program_timer%timer_end('IO')

        call md%evolve_one_step(global_dt)

        if (md%domains(1)%time > final_time) exit
    end do

    call program_timer%timer_end('evolve')
    call md%finalise_and_print_timers

    write(log_output_unit,*) ''
    write(log_output_unit, *) 'Program timer'
    write(log_output_unit, *) ''
    call program_timer%print(log_output_unit)
    call swals_mpi_finalize
end program


    Program zstedc_example

!     ZSTEDC 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: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zhbtrd, zstedc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, j, k, kd, ldab, ldz, lgn, liwork, lrwork, &
        lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), work(:), z(:, :)
      Complex (Kind=dp) :: cdum(1)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:)
      Real (Kind=dp) :: rdum(1)
      Integer :: idum(1)
      Integer, Allocatable :: iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, ceiling, conjg, log, max, maxloc, min, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZSTEDC Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd
      ldab = kd + 1
      ldz = n
      lgn = ceiling(log(real(n,kind=dp))/log(2.0_dp))
      Allocate (ab(ldab,n), z(ldz,n), d(n), e(n-1))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      lrwork = -1
      liwork = -1
      Call zstedc('V', n, d, e, z, ldz, cdum, lwork, rdum, lrwork, idum, &
        liwork, info)

!     Make sure that there is enough workspace.
      lwork = max(n*n, nint(real(cdum(1))))
      lrwork = max(1+3*n+2*n*lgn+4*n*n, nint(rdum(1)))
      liwork = max(6+6*n+5*n*lgn, idum(1))
      Allocate (work(lwork), rwork(lrwork), iwork(liwork))

!     Read the upper or lower triangular part of the band matrix A
!     from data file

      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If

!     Reduce A to tridiagonal form T = (Z**T)*A*Z, and form Z

      Call zhbtrd('V', uplo, n, kd, ab, ldab, d, e, z, ldz, work, info)

!     Calculate all the eigenvalues and eigenvectors of A,
!     from T and Z

      Call zstedc('V', n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, &
        liwork, info)

      If (info==0) Then

!       Print eigenvalues and eigenvectors

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

        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, n
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(z(k,i))/abs(z(k,i))/dznrm2(n, z(1,i), 1)
          z(1:n, i) = z(1:n, i)*scal
        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_complex_gen_comp('General', ' ', n, n, z, &
          ldz, 'Bracketed', 'F7.4', 'Eigenvectors', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

      Else
        Write (nout, 110) 'Failure in ZSTEDC. INFO = ', info
      End If

100   Format (4X, F8.4, 3(10X,F8.4))
110   Format (1X, A, I10)
    End Program


SUBROUTINE beta_pred (mjd, r_sat, v_sat, fti, ft0, beta)

! ----------------------------------------------------------------------
! SUBROUTINE: beta_pred.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the beta angle (Sun elevation angle w.r.t. orbtial plane) at a previous of future epoch
!  based on the Keplerian elements for the satellite orbit propagation and the DE Ephemeris for the Sun position
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number in GPS Time (including the fraction of the day)
! - r_sat: 		Satellite position vector (m) in ITRF
! - v_sat: 		Satellite velocity vector (m/sec) in ITRF
! - fti:		Orbit angle (degrees) at the input epoch ti
! - ft0:		Orbit angle (degrees) at the required epoch t0 (forward or backward)
!
! Output arguments:
! - beta:		Sun elevation angle with respect to the orbital plane at the epoch t0 (degrees)
! ----------------------------------------------------------------------
! Note 1:
! - kepler:		Kepler elements array (6)
!   a:       	semi-major axis  (m)
!   e:      	eccentricity
!   i:      	inclination (degrees)
!   Omega:  	right ascension of the ascending node (degrees)
!   omega:  	argument of perigee (degrees)
!   E:      	eccentric anomaly (degrees)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia              8 June 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_planets
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, r_sat(3), v_sat(3)
      REAL (KIND = prec_q), INTENT(IN) :: fti, ft0
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: beta
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: ti, t0, frate
      REAL (KIND = prec_q) :: mjd_t0 , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC
      INTEGER (KIND = prec_int8) :: Norb, i, sz1, sz2
      REAL (KIND = prec_q) :: GM, kepler_i(9), kepler_0(6), a_semiaxis, ec, n_motion, Ei_rad, Mi_rad, Mo_rad, Mo_deg, Eo_deg
      REAL (KIND = prec_q) :: dt
      REAL (KIND = prec_q), DIMENSION(3) :: rsat_t0, vsat_t0
! ----------------------------------------------------------------------
! Planetary/Lunar Epehemeris data processing (lib3_planets): Variables declaration
      DOUBLE PRECISION  JD_TT, R_eph(6)
      INTEGER  NTARG, NCTR
!      CHARACTER (LEN=100) :: fname_header, fname_data, fname_out
      REAL (KIND = prec_d) :: rsun_t0(3)
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: NPint

! ----------------------------------------------------------------------
! Current epoch in seconds since start of the day (0h)
ti = (mjd - INT(mjd)) * 86400.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of the forward/backward epoch t0
! ----------------------------------------------------------------------
! Orbital angle rate (in degrees/sec)
frate = sqrt( (v_sat(1)**2+v_sat(2)**2+v_sat(3)**2) / (r_sat(1)**2+r_sat(2)**2+r_sat(3)**2) ) * (180.0D0 / PI_global)

t0 = ti + (ft0 - fti)/ frate
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of the satellite position and velocity vectors at epoch t0
! through Keplerian orbit consideration
! ----------------------------------------------------------------------
! Gravitational constant
GM = 0.39860044150D+15

! Kepler elements at ti
CALL kepler_z2k (r_sat, v_sat, GM, kepler_i)

a_semiaxis = kepler_i(1)
ec = kepler_i(2)

! Eccentric anomaly at ti (radians)
Ei_rad = kepler_i(7) * (PI_global / 180.D0)

! Mean anomaly  at ti (radians)
Mi_rad = Ei_rad - ec * sin(Ei_rad)

! mean motion (rad/sec)
n_motion = sqrt(GM / a_semiaxis**3)

! ----------------------------------------------------------------------
! Time difference since current epoch
dt = t0 - ti
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Mean anomaly (radians) at epoch t0
Mo_rad = Mi_rad + n_motion * dt

! Mean anomaly (in degrees) at epoch t0
Mo_deg = Mo_rad * (180.D0/PI_global)

! Angle reduction within the range {0 - 360} degrees
If (abs(Mo_deg) >= 360.D0) then
	Mo_deg = Mo_deg - INT(Mo_deg / 360.D0) * 360.D0
End If

if (Mo_deg < 0.0D0) then
    Mo_deg = Mo_deg + 360.D0
end if
! ----------------------------------------------------------------------

! Kepler Equation
! Eccentric anomaly (degrees) at epoch t0 obtained by solving Kepler's Equation
CALL kepler_eq ( Mo_deg , ec , Eo_deg)

! Kepler elements at epoch t0
!kepler_0 = (/ a, e, i, Omega_asc, omega_per, Eo_deg /)
kepler_0 = (/ kepler_i(1), kepler_i(2), kepler_i(3), kepler_i(4), kepler_i(5), Eo_deg /)

! State vector (Cartesian coordinates) at epoch t0
CALL kepler_k2z (kepler_0, GM, rsat_t0, vsat_t0)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Sun position vector at reference epoch t0
! ----------------------------------------------------------------------
! Center celestial body : Earth
      NCTR = 3
! Target celestial body : Sun
      NTARG = 11

! Time System transformation: GPS to TT
mjd_t0 = mjd + dt/86400.0D0
CALL time_GPS (mjd_t0 , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)

! JD at the epoch t0 (in TT)
      JD_TT = mjd_TT + 2400000.5D0

! Sun state vector in ICRF (in KM)
      CALL  PLEPH ( JD_TT, NTARG, NCTR, R_eph )

	  ! Km to meters
	  rsun_t0(1) = R_eph(1) * 1000D0
	  rsun_t0(2) = R_eph(2) * 1000D0
	  rsun_t0(3) = R_eph(3) * 1000D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Sun elevation angle at epoch t0
! ----------------------------------------------------------------------
! Beta angle (in degrees)
      CALL beta_angle (rsat_t0, vsat_t0, rsun_t0, beta)
! ----------------------------------------------------------------------

if (1<0) then
PRINT *, "fti,ft0,frate", fti, ft0, frate
PRINT *, "ti, t0, dt", ti, t0, dt
PRINT *, "kepler_i", kepler_i
PRINT *, "kepler_0", kepler_0
!PRINT *, "Mi_deg", Mi_rad*(180.D0/PI_global)
!PRINT *, "Mo_deg", Mo_deg
PRINT *, "frate ", frate
PRINT *, "n_motion ", n_motion * (180.0D0 / PI_global)

PRINT *, "beta", beta
PRINT *, "rsat_t0", rsat_t0
PRINT *, "vsat_t0", vsat_t0
end if

END


      SUBROUTINE SPEAR(DATA1,DATA2,N,WKSP1,WKSP2,D,ZD,PROBD,RS,PROBRS)
      DIMENSION DATA1(N),DATA2(N),WKSP1(N),WKSP2(N)
      DO 11 J=1,N
        WKSP1(J)=DATA1(J)
        WKSP2(J)=DATA2(J)
11    CONTINUE
      CALL SORT2(N,WKSP1,WKSP2)
      CALL CRANK(N,WKSP1,SF)
      CALL SORT2(N,WKSP2,WKSP1)
      CALL CRANK(N,WKSP2,SG)
      D=0.
      DO 12 J=1,N
        D=D+(WKSP1(J)-WKSP2(J))**2
12    CONTINUE
      EN=N
      EN3N=EN**3-EN
      AVED=EN3N/6.-(SF+SG)/12.
      FAC=(1.-SF/EN3N)*(1.-SG/EN3N)
      VARD=((EN-1.)*EN**2*(EN+1.)**2/36.)*FAC
      ZD=(D-AVED)/SQRT(VARD)
      PROBD=ERFCC(ABS(ZD)/1.4142136)
      RS=(1.-(6./EN3N)*(D+0.5*(SF+SG)))/FAC
      T=RS*SQRT((EN-2.)/((1.+RS)*(1.-RS)))
      DF=EN-2.
      PROBRS=BETAI(0.5*DF,0.5,DF/(DF+T**2))
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine set_deps
  use global_variables
  implicit none
  integer :: ikr,ikz

  select case(nband_type)
  case(N_PARABOLIC_BAND)
!$omp parallel do private(ikz, ikr)
    do ikz = -NKz,NKz
      do ikr = 1,NKr
        deps(ikr,ikz) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      end do
    end do
  case(N_NONPARABOLIC_BAND)
!$omp parallel do private(ikz, ikr)
    do ikz = -NKz,NKz
      do ikr = 1,NKr
        deps(ikr,ikz) = eps_g*sqrt(1d0 + (kr(ikr)**2+kz(ikz)**2)/(mass_r*eps_g))
      end do
    end do
  case default
    write(*,"(A,2x,A)")"Invalid nband_type",nband_type
    stop
  end select

  return
end subroutine set_deps


      REAL FUNCTION EPSLON (X)
C
C ESTIMATE MACHINE ARITHMETIC ROUNDOFF IN QUANTITIES OF SIZE X
C
C     THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS
C     SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
C        1.  THE BASE USED IN REPRESENTING FLOATING POINT
C            NUMBERS IS NOT A POWER OF THREE.
C        2.  THE QUANTITY  A  IN STATEMENT 10 IS REPRESENTED TO
C            THE ACCURACY USED IN FLOATING POINT VARIABLES
C            THAT ARE STORED IN MEMORY.
C     THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
C     FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING
C     ASSUMPTION 2.
C     UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
C            A  IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
C            B  HAS A ZERO FOR ITS LAST BIT OR DIGIT,
C            C  IS NOT EXACTLY EQUAL TO ONE,
C            EPS  MEASURES THE SEPARATION OF 1.0 FROM
C                 THE NEXT LARGER FLOATING POINT NUMBER.
C
C CALLED BY: INPUT
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C APPROXIMATED VALUE
      REAL X
C
C------ Local Variables ------------------------------------------------
C
      REAL A,B,C,EPS
C
C----- Executable Statements -------------------------------------------
C
      A = 4.0E0/3.0E0
   10 B = A - 1.0E0
      C = B + B + B
      EPS = ABS(C-1.0E0)
      IF (EPS .EQ. 0.0E0) GO TO 10
      EPSLON = EPS*ABS(X)
      RETURN
      END