MODULE utils
  USE precision1, only : dp,qp
  IMPLICIT NONE

  interface rj
      module procedure rj_c,rj_r
  end interface rj

  interface rd
      module procedure rd_c,rd_r
  end interface rd

  interface rf
      module procedure rf_c,rf_r
  end interface rf

  interface rc
      module procedure rc_c,rc_r
  end interface rc

CONTAINS

  FUNCTION gaussint(func,a,b)
    !Use this integrator when lower bound is a singularity
    USE abscissae
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: a,b
    REAL(DP) :: gaussint
    INTERFACE
            FUNCTION func(x)
              USE precision1
              IMPLICIT NONE
              REAL(DP), INTENT(IN) :: x
              REAL(DP) :: func
            END FUNCTION func
    END INTERFACE
    INTEGER, PARAMETER :: m = 33
    INTEGER :: i
    REAL(DP) :: xm,xr,s,dx,f1,f2
    REAL(DP), DIMENSION(m) :: x,w

    call kwadratury(m,x,w)
    xm = 0.5_dp*(b+a)
    xr = 0.5_dp*(b-a)
    s = 0._dp

    do i = 1,m
       dx = xr*x(i)
       f1 = func(dx+xm)
       f2 = func(-dx+xm)
       s = s + w(i)*(f1 + f2)

       if (isnan(f1).or.isnan(f2)) then
          ! write(*,*) 'Warning: check integrand is real in interval!'
          gaussint = xr*s
          RETURN
       end if

    end do

    gaussint = xr*s

  END FUNCTION gaussint

  ! Taken from CAMB (version MAY 2016)
  FUNCTION rombint2(f,a,b,tol, maxit, minsteps)
    !  Rombint returns the integral from a to b of using Romberg integration.
    !  The method converges provided that f(x) is continuous in (a,b).
    !  f must be real(dp) and must be declared external in the calling
    !  routine.  tol indicates the desired relative accuracy in the integral.

    ! Modified by AL to specify max iterations and minimum number of steps
    ! (min steps useful to stop wrong results on periodic or sharp functions)
    implicit none
    integer, parameter :: MAXITER=20,MAXJ=5
    dimension g(MAXJ+1)
    real(dp) f
    external f
    real(dp) :: rombint2
    real(dp), intent(in) :: a,b,tol
    integer, intent(in):: maxit,minsteps

    integer :: nint, i, k, jmax, j
    real(dp) :: h, gmax, error, g, g0, g1, fourj

    h=0.5_dp*(b-a)
    gmax=h*(f(a)+f(b))
    g(1)=gmax
    nint=1
    error=1.0e20_dp
    i=0
    do
       i=i+1
       if (i > maxit.or.(i > 5.and.abs(error) < tol) .and. nint > minsteps) exit
       !  Calculate next trapezoidal rule approximation to integral.
       g0=0._dp
       do k=1,nint
          g0=g0+f(a+(k+k-1)*h)
       end do
       g0=0.5_dp*g(1)+h*g0
       h=0.5_dp*h
       nint=nint+nint
       jmax=min(i,MAXJ)
       fourj=1._dp
       do j=1,jmax
          !  Use Richardson extrapolation.
          fourj=4._dp*fourj
          g1=g0+(g0-g(j))/(fourj-1._dp)
          g(j)=g0
          g0=g1
       end do
       if (abs(g0).gt.tol) then
          error=1._dp-gmax/g0
       else
          error=gmax
       end if
       gmax=g0
       g(jmax+1)=g0
    end do

    rombint2=g0
    if (i > maxit .and. abs(error) > tol)  then
       write(*,*) 'Warning: Rombint2 failed to converge; '
       write (*,*)'integral, error, tol:', rombint2,error, tol
    end if

  END FUNCTION rombint2

  SUBROUTINE spline(x,y,n,yp1,ypn,y2)
    IMPLICIT NONE
    INTEGER :: n,nmax,i,k
    parameter (nmax=2000)
    REAL(dp) :: yp1,ypn,x(n),y(n),y2(n)
    REAL(dp) :: p,qn,sig,un,u(nmax)

    if (yp1 > .99e30) then
       y2(1)=0._dp
        u(1)=0._dp
    else
        y2(1)=-0.5_dp
        u(1)=(3._dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
    endif

    do i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2._dp
        y2(i)=(sig-1._dp)/p
        u(i)=(6._dp*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
              /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
    end do

    if(ypn > .99e30) then
        qn=0._dp
        un=0._dp
    else
        qn=0.5_dp
        un=(3._dp/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
    endif

    y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1._dp)

    do k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
    enddo

    RETURN
  END SUBROUTINE spline

  SUBROUTINE splint(xa,ya,y2a,n,x,y)
    IMPLICIT NONE
    INTEGER :: n,k,khi,klo
    REAL(dp) :: x,y,xa(n),y2a(n),ya(n),a,b,h

    klo=1
    khi=n
    do while (khi-klo > 1)
    k=(khi+klo)/2
    if(xa(k) > x) then
        khi=k
    else
        klo=k
    endif
    end do

    h=xa(khi)-xa(klo)

    if(h == 0._dp) stop 'bad xa input in splint'

    a=(xa(khi)-x)/h
    b=(x-xa(klo))/h
    y=a*ya(klo)+b*ya(khi)+ &
      ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6._dp

    return

  END SUBROUTINE splint

  FUNCTION rtbis(func,x1,x2,xacc)
    !Taken from  numerical recipes. Bisection method
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x1,x2,xacc
    REAL(DP) :: rtbis
    INTERFACE
        FUNCTION func(x)
            USE precision1
            IMPLICIT NONE
            REAL(DP), INTENT(IN) :: x
            REAL(DP) :: func
        END FUNCTION func
    END INTERFACE
    INTEGER, PARAMETER :: MAXIT=200
    INTEGER :: j
    LOGICAL :: succes
    REAL(DP) :: a,b,dx,f,fmid,xmid
    a=x1
    b=x2
    fmid=func(b)
    f=func(a)
    if (f*fmid >= 0.0) then
        call zbrac(func,a,b,succes)
        if (.not. succes) STOP 'rtbis: root not bracketed'
    end if
    if (f < 0.0) then
            rtbis=a
            dx=b-a
    else
            rtbis=b
            dx=a-b
    end if
    do j=1,MAXIT
            dx=dx*0.5_dp
            xmid=rtbis+dx
            fmid=func(xmid)
            if (fmid <= 0.0) rtbis=xmid
            if (abs(dx) < xacc .or. fmid == 0.0) RETURN
    end do
    print *, 'rtbis: too many bisections'
  END FUNCTION rtbis

  SUBROUTINE zbrac(func,x1,x2,succes)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT) :: x1,x2
    LOGICAL, INTENT(OUT) :: succes
    INTERFACE
        FUNCTION func(x)
            USE precision1
            IMPLICIT NONE
            REAL(DP), INTENT(IN) :: x
            REAL(DP) :: func
        END FUNCTION func
    END INTERFACE
    INTEGER, PARAMETER :: NTRY=50
    REAL(DP), PARAMETER :: FACTOR=1.6_dp
    INTEGER :: j
    REAL(DP) :: f1,f2
    if (x1 == x2) STOP 'zbrac: you have to guess an initial range'
    f1=func(x1)
    f2=func(x2)
    succes=.true.
    do j=1,NTRY
        if ((f1 > 0.0 .and. f2 < 0.0) .or. &
                (f1 < 0.0 .and. f2 > 0.0)) RETURN
        if (abs(f1) < abs(f2)) then
            x1=x1+FACTOR*(x1-x2)
            f1=func(x1)
        else
            x2=x2+FACTOR*(x2-x1)
            f2=func(x2)
        end if
    end do
    succes=.false.
  END SUBROUTINE zbrac

  FUNCTION rtsafe(funcd,x1,x2,xacc)
    !double precision version of nr recipe
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x1,x2,xacc
    REAL(DP) :: rtsafe
    INTERFACE
            SUBROUTINE funcd(x,fval,fderiv)
              USE precision1
              IMPLICIT NONE
              REAL(DP), INTENT(IN) :: x
              REAL(DP), INTENT(OUT) :: fval,fderiv
            END SUBROUTINE funcd
    END INTERFACE
    INTEGER, PARAMETER :: MAXIT=100
    INTEGER :: j
    REAL(DP) :: df,dx,dxold,f,fh,fl,temp,xh,xl
    call funcd(x1,fl,df)
    call funcd(x2,fh,df)
    if ((fl > 0.0_dp .and. fh > 0.0_dp) .or. &
            (fl < 0.0_dp .and. fh < 0.0_dp)) &
            print *, 'root must be bracketed in rtsafe'
    if (fl == 0.0_dp) then
            rtsafe=x1
            RETURN
    else if (fh == 0.0_dp) then
            rtsafe=x2
            RETURN
    else if (fl < 0.0_dp) then
            xl=x1
            xh=x2
    else
            xh=x1
            xl=x2
    end if
    rtsafe=0.5_dp*(x1+x2)
    dxold=abs(x2-x1)
    dx=dxold
    call funcd(rtsafe,f,df)
    do j=1,MAXIT
            if (((rtsafe-xh)*df-f)*((rtsafe-xl)*df-f) > 0.0_dp .or. &
                 abs(2.0_dp*f) > abs(dxold*df) ) then
            dxold=dx
            dx=0.5_dp*(xh-xl)
            rtsafe=xl+dx
            if (xl == rtsafe) RETURN
       else
            dxold=dx
            dx=f/df
            temp=rtsafe
            rtsafe=rtsafe-dx
            if (temp == rtsafe) RETURN
       end if
       if (abs(dx) < xacc) RETURN
       call funcd(rtsafe,f,df)
       if (f < 0.0_dp) then
            xl=rtsafe
       else
            xh=rtsafe
       end if
    end do
    print *, 'rtsafe: too many bisections'
  END FUNCTION rtsafe

  FUNCTION zbrent(func,x1,x2,tol)
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x1,x2,tol
    REAL(DP) :: zbrent
    INTERFACE
        FUNCTION func(x)
            USE precision1
            IMPLICIT NONE
            REAL(DP), INTENT(IN) :: x
            REAL(DP) :: func
        END FUNCTION func
    END INTERFACE
    INTEGER, PARAMETER :: ITMAX=100
    REAL(DP), PARAMETER :: EPS=epsilon(x1)
    INTEGER :: iter
    LOGICAL :: succes
    REAL(DP) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm
    a=x1
    b=x2
    fa=func(a)
    fb=func(b)
    if ((fa > 0.0_dp .and. fb > 0.0_dp) .or. (fa < 0.0_dp .and. fb < 0.0_dp)) then
        call zbrac(func,a,b,succes)
        if (.not. succes) STOP 'zbrent: root not bracketed'
    end if
    c=b
    fc=fb
    do iter=1,ITMAX
        if ((fb > 0.0_dp .and. fc > 0.0_dp) .or. (fb < 0.0_dp .and. fc < 0.0_dp)) then
            c=a
            fc=fa
            d=b-a
            e=d
        end if
        if (abs(fc) < abs(fb)) then
            a=b
            b=c
            c=a
            fa=fb
            fb=fc
            fc=fa
        end if
        tol1=2.0_dp*EPS*abs(b)+0.5_dp*tol
        xm=0.5_dp*(c-b)
        if (abs(xm) <= tol1 .or. fb == 0.0_dp) then
            zbrent=b
            RETURN
        end if
        if (abs(e) >= tol1 .and. abs(fa) > abs(fb)) then
            s=fb/fa
            if (a == c) then
                p=2.0_dp*xm*s
                q=1.0_dp-s
            else
                q=fa/fc
                r=fb/fc
                p=s*(2.0_dp*xm*q*(q-r)-(b-a)*(r-1.0_dp))
                q=(q-1.0_dp)*(r-1.0_dp)*(s-1.0_dp)
            end if
            if (p > 0.0_dp) q=-q
            p=abs(p)
            if (2.0_dp*p  <  min(3.0_dp*xm*q-abs(tol1*q),abs(e*q))) then
                e=d
                d=p/q
            else
                d=xm
                e=d
            end if
        else
            d=xm
            e=d
        end if
        a=b
        fa=fb
        b=b+merge(d,sign(tol1,xm), abs(d) > tol1 )
        fb=func(b)
    end do
    print *, 'zbrent: exceeded maximum iterations'
    zbrent=b
  END FUNCTION zbrent

  subroutine fcubic_roots(p_coeff,q_coeff,roots)
    ! Find roots of depressed cubic:
    ! y^3 + py + q = 0
    use constants, only : PI,PIO3,THIRD,SQRT3
    implicit none
    real(dp), intent(in) :: p_coeff,q_coeff
    complex(dp), dimension(3), intent(out) :: roots
    real(dp) :: Dt,tht,ry1,ry2,iy2,ry3,iy3
    real(dp) :: Q,R,D,w3,S,T
! The discriminant is: -4p^3 - 27q^2
    Dt=-4._dp*p_coeff**3-27._dp*q_coeff**2
! Roots found using Cardano's formula
! https://proofwiki.org/wiki/Cardano%27s_Formula
    if (Dt < 0._dp) then
! One real root y1 and a complex conjugate pair y2 = y3*
        Q=THIRD*p_coeff
        R=-0.5_dp*q_coeff
        D=Q**3+R**2 !NOT the usual discriminant D=Dt/(-27*4)
        ! S=(R+sqrt(D))**THIRD
        ! T=(R-sqrt(D))**THIRD
        w3=R+sign(1._dp,R)*sqrt(D)
        S=cbrt(w3)
        T=-Q/S
! The roots
        ry1=S+T
        ry2=-0.5_dp*ry1
        iy2=0.5_dp*SQRT3*(S-T)
        ry3=ry2
        iy3=-iy2
    else if (Dt > 0.0_dp) then ! three distinct real roots
        iy2=0._dp
        iy3=0._dp
        tht=THIRD*acos(1.5_dp * q_coeff/p_coeff * sqrt(-3._dp/p_coeff))
        ry1=2._dp*sqrt(-p_coeff*THIRD)*cos(tht)
        ry2=2._dp*sqrt(-p_coeff*THIRD)*cos(tht-2._dp*PIO3)
        ry3=2._dp*sqrt(-p_coeff*THIRD)*cos(tht-4._dp*PIO3)
    else ! Dt = 0 ! Two real distinct roots: y1, y2 = y3
        R=-0.5_dp*q_coeff
        S=cbrt(R)
        ry1=2._dp*S
        ry2=-S
        iy2=0._dp
        ry3=ry2
        iy3=0._dp
    end if
    roots(1)=dcmplx(ry1,0._dp)
    roots(2)=dcmplx(ry2,iy2)
    roots(3)=dcmplx(ry3,iy3)
  end subroutine fcubic_roots

  PURE FUNCTION cbrt(x)
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP) :: cbrt
    REAL(DP), PARAMETER :: THIRD=1._dp/3._dp
    cbrt=sign(abs(x)**THIRD,x)
  END FUNCTION CBRT

  SUBROUTINE laguer(a,x,its)
    IMPLICIT NONE
    INTEGER, INTENT(OUT) :: its
    COMPLEX(DP), INTENT(INOUT) :: x
    COMPLEX(DP), DIMENSION(:), INTENT(IN) :: a
    REAL(DP), PARAMETER :: EPS=epsilon(1.0_dp)
    INTEGER, PARAMETER :: MR=8,MT=10,MAXIT=MT*MR
    INTEGER :: iter,m
    REAL(DP) :: abx,abp,abm,err
    COMPLEX(DP) :: dx,x1,f,g,h,sq,gp,gm,g2,abx_c
    COMPLEX(DP), DIMENSION(size(a)) :: b,d
    REAL(DP), DIMENSION(MR) :: frac = &
            (/ 0.5_dp,0.25_dp,0.75_dp,0.13_dp,0.38_dp,0.62_dp,0.88_dp,1.0_dp /)
    m=size(a)-1
    do iter=1,MAXIT
        its=iter
        abx=abs(x)
        b(m+1:1:-1)=poly_term(a(m+1:1:-1),x)
        d(m:1:-1)=poly_term(b(m+1:2:-1),x)
        f=poly(x,d(2:m))
        abx_c=dcmplx(abx)
        err=EPS*real(poly(abx_c,dcmplx(abs(b(1:m+1)))))
        if (abs(b(1)) <= err) RETURN
        g=d(1)/b(1)
        g2=g*g
        h=g2-2.0_dp*f/b(1)
        sq=sqrt((m-1)*(m*h-g2))
        gp=g+sq
        gm=g-sq
        abp=abs(gp)
        abm=abs(gm)
        if (abp < abm) gp=gm
        if (max(abp,abm) > 0.0) then
            dx=m/gp
        else
            dx=exp(dcmplx(log(1.0_dp+abx),iter))
        end if
        x1=x-dx
        if (x == x1) RETURN
        if (mod(iter,MT) /= 0) then
            x=x1
        else
            x=x-dx*frac(iter/MT)
        end if
    end do
    print *, 'laguer: too many iterations'
  END SUBROUTINE laguer

  SUBROUTINE zroots(a,roots,polish)
    IMPLICIT NONE
    COMPLEX(DP), DIMENSION(:), INTENT(IN) :: a
    COMPLEX(DP), DIMENSION(:), INTENT(OUT) :: roots
    LOGICAL, INTENT(IN) :: polish
    REAL(DP), PARAMETER :: EPS=1.0e-8_dp
    INTEGER :: j,its,m
    INTEGER, DIMENSION(size(roots)) :: indx
    COMPLEX(DP) :: x
    COMPLEX(DP), DIMENSION(size(a)) :: ad
    m=size(a)-1
    ad(:)=a(:)
    do j=m,1,-1
        x=dcmplx(0.0_dp)
        call laguer(ad(1:j+1),x,its)
        if (abs(aimag(x)) <= 2.0_dp*EPS**2*abs(real(x))) &
                x=dcmplx(real(x))
        roots(j)=x
        ad(j:1:-1)=poly_term(ad(j+1:2:-1),x)
    end do
    if (polish) then
        do j=1,m
            call laguer(a(:),roots(j),its)
        end do
    end if
  END SUBROUTINE zroots

  FUNCTION poly(x,coeffs)
    COMPLEX(DP), INTENT(IN) :: x
    COMPLEX(DP), DIMENSION(:), INTENT(IN) :: coeffs
    COMPLEX(DP) :: poly
    COMPLEX(DP) :: pow
    COMPLEX(DP), DIMENSION(:), ALLOCATABLE :: vec
    INTEGER, PARAMETER :: NPAR_POLY=8
    INTEGER :: i,n,nn
    n=size(coeffs)
    if (n <= 0) then
        poly=0.0_dp
    else if (n < NPAR_POLY) then
        poly=coeffs(n)
        do i=n-1,1,-1
            poly=x*poly+coeffs(i)
        end do
    else
        allocate(vec(n+1))
        pow=x
        vec(1:n)=coeffs
        do
            vec(n+1)=0.0_dp
            nn=ishft(n+1,-1)
            vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
            if (nn == 1) exit
            pow=pow*pow
            n=nn
        end do
        poly=vec(1)
        deallocate(vec)
    end if
  END FUNCTION poly

  RECURSIVE FUNCTION poly_term(a,b) RESULT(u)
    COMPLEX(DP), DIMENSION(:), INTENT(IN) :: a
    COMPLEX(DP), INTENT(IN) :: b
    COMPLEX(DP), DIMENSION(size(a)) :: u
    INTEGER, PARAMETER :: NPAR_POLYTERM=8
    INTEGER :: n,j
    n=size(a)
    if (n <= 0) RETURN
    u(1)=a(1)
    if (n < NPAR_POLYTERM) then
        do j=2,n
            u(j)=a(j)+b*u(j-1)
        end do
    else
        u(2:n:2)=poly_term(a(2:n:2)+a(1:n-1:2)*b,b*b)
        u(3:n:2)=a(3:n:2)+b*u(2:n-1:2)
    end if
  END FUNCTION poly_term

  FUNCTION dfridr(func,x,h,err)
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x,h
    REAL(DP), INTENT(OUT) :: err
    REAL(DP) :: dfridr
    INTERFACE
       FUNCTION func(x)
         USE precision1
         IMPLICIT NONE
         REAL(DP), INTENT(IN) :: x
         REAL(DP) :: func
       END FUNCTION func
    END INTERFACE
    INTEGER, PARAMETER :: NTAB=10
    REAL(DP), PARAMETER :: CON=1.4_dp,CON2=CON*CON,BIG=huge(x),SAFE=2.0
    INTEGER :: ierrmin,i,j
    REAL(DP) :: hh
    REAL(DP), DIMENSION(NTAB-1) :: errt,fac
    REAL(DP), DIMENSION(NTAB,NTAB) :: a
    hh=h
    a(1,1)=(func(x+hh)-func(x-hh))/(2.0_dp*hh)
    err=BIG
    fac(1:NTAB-1)=geop(CON2,CON2,NTAB-1)
    do i=2,NTAB
       hh=hh/CON
       a(1,i)=(func(x+hh)-func(x-hh))/(2.0_dp*hh)
       do j=2,i
          a(j,i)=(a(j-1,i)*fac(j-1)-a(j-1,i-1))/(fac(j-1)-1.0_dp)
       end do
       errt(1:i-1)=max(abs(a(2:i,i)-a(1:i-1,i)),abs(a(2:i,i)-a(1:i-1,i-1)))
       ierrmin=iminloc(errt(1:i-1))
       if (errt(ierrmin) <= err) then
          err=errt(ierrmin)
          dfridr=a(1+ierrmin,i)
       end if
       if (abs(a(i,i)-a(i-1,i-1)) >= SAFE*err) RETURN
    end do
  END FUNCTION dfridr

  FUNCTION iminloc(arr)
    REAL(DP), DIMENSION(:), INTENT(IN) :: arr
    INTEGER, DIMENSION(1) :: imin
    INTEGER :: iminloc
    imin=minloc(arr(:))
    iminloc=imin(1)
  END FUNCTION iminloc

  FUNCTION geop(first,factor,n)
    REAL(DP), INTENT(IN) :: first,factor
    INTEGER, INTENT(IN) :: n
    REAL(DP), DIMENSION(n) :: geop
    INTEGER, PARAMETER :: NPAR_GEOP=4
    INTEGER, PARAMETER :: NPAR2_GEOP=2
    INTEGER :: k,k2
    REAL(DP) :: temp
    if (n > 0) geop(1)=first
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop(k)=geop(k-1)*factor
       end do
    else
       do k=2,NPAR2_GEOP
          geop(k)=geop(k-1)*factor
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop(k+1:min(k2,n))=temp*geop(1:min(k,n-k))
          temp=temp*temp
          k=k2
       end do
    end if
  END FUNCTION geop

  function rc_c(x,y)
      implicit none
      complex(dp), intent(in) :: x,y
      complex(dp) :: rc_c
      real(dp), parameter :: r=1.0e-4_dp,&
              C1=0.3_dp,C2=1._dp/7._dp,C3=3._dp/8._dp,&
              C4=9._dp/22._dp,C5=159._dp/208._dp,C6=9._dp/8._dp
      real(dp) :: Q,m1
      complex(dp) :: xm,ym,y0,w,A0,sqrtx,sqrty,lambm,Am,s
      if ((real(y) < 0.) .and. (aimag(y) == 0.)) then
          xm=x-y
          ym=-y
          w=sqrt(x/(x-y))
      else
          xm=x
          ym=y
          w=dcmplx(1._dp,0._dp)
      end if
      y0=ym
      A0=(xm+2._dp*ym)/3._dp
      Q=(r*3._dp)**(-0.125_dp)*abs(A0-xm)
      Am=A0
      m1=1._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          lambm=2._dp*sqrtx*sqrty+ym
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      s=m1*(y0-A0)/Am
      rc_c=w*(1._dp + C1*s**2 + C2*s**3 + C3*s**4 &
              + C4*s**5 + C5*s**6 + C6*s**7)/sqrt(Am)
  end function rc_c

  function rc_r(x,y)
      implicit none
      real(dp), intent(in) :: x,y
      real(dp) :: rc_r
      real(dp), parameter :: r=1.0e-4_dp,&
              C1=0.3_dp,C2=1._dp/7._dp,C3=3._dp/8._dp,&
              C4=9._dp/22._dp,C5=159._dp/208._dp,C6=9._dp/8._dp
      real(dp) :: Q,m1
      real(dp) :: xm,ym,y0,w,A0,sqrtx,sqrty,lambm,Am,s
      if (real(y) < 0.) then
          xm=x-y
          ym=-y
          w=sqrt(x/(x-y))
      else
          xm=x
          ym=y
          w=1._dp
      end if
      y0=ym
      A0=(xm+2._dp*ym)/3._dp
      Q=(r*3._dp)**(-0.125_dp)*abs(A0-xm)
      Am=A0
      m1=1._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          lambm=2._dp*sqrtx*sqrty+ym
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      s=m1*(y0-A0)/Am
      rc_r=w*(1._dp + C1*s**2 + C2*s**3 + C3*s**4 &
              + C4*s**5 + C5*s**6 + C6*s**7)/sqrt(Am)
  end function rc_r

  function rj_c(x,y,z,p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Future work: implement special case when x,y,z real and nonnegative   !
! with at most one allowed to be zero, and real(p)<=0.                  !
! Note case when x,y,z are complex has not been established (not dealt  !
! with in arxiv:math/9409227v1)                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      complex(dp), intent(in) :: x,y,z,p
      complex(dp) :: rj_c
      real(dp), parameter :: r=1.0e-4_dp
      real(dp), parameter :: C1=3._dp/14._dp, C2=1._dp/6._dp, C3=9._dp/88._dp
      real(dp), parameter :: C4=3._dp/22._dp, C5=9._dp/52._dp, C6=3._dp/26._dp
      real(dp) :: Q,m1
      complex(dp) :: xm,ym,zm,pm,A0,delta,Am,lambm,dm,em
      complex(dp) :: sqrtx,sqrty,sqrtz,sqrtp
      complex(dp) :: X1,Y1,Z1,P1,XYZ,E2,E3,E4,E5
      complex(dp) :: sum1,xarg,yarg
      ! Future work: implement special case when x,y,z real and nonnegative
      ! with at most one allowed to be zero, and real(p)<=0.
      ! Note case when x,y,z are complex has not been established (not dealt
      ! with in arxiv:math/9409227v1)
      if (real(p) <= 0.) then
          STOP 'need real(p)>0 for this implementation of Rj to work'
      else
          xm=x
          ym=y
          zm=z
          pm=p
      end if
      A0=(xm+ym+zm+2._dp*pm)*0.2_dp
      delta=(pm-xm)*(pm-ym)*(pm-zm)
      Q=(r*0.25_dp)**(-1._dp/6._dp) &
              * max(abs(A0-xm),abs(A0-ym),abs(A0-zm),abs(A0-pm))
      Am=A0
      m1=1._dp
      sum1=0._dp
      xarg=1._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          sqrtp=sqrt(pm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          dm=(sqrtp+sqrtx)*(sqrtp+sqrty)*(sqrtp+sqrtz)
          em=m1**3*delta/dm**2
          yarg=1._dp+em
          sum1=sum1+m1/dm*rc(xarg,yarg)
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          pm=0.25_dp*(pm+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      X1=(A0-x)*m1/Am
      Y1=(A0-y)*m1/Am
      Z1=(A0-z)*m1/Am
      P1=-0.5_dp*(X1+Y1+Z1)
      XYZ=X1*Y1*Z1
      e2=X1*Y1+X1*Z1+Y1*Z1-3._dp*P1**2
      e3=XYZ+2._dp*(e2+2._dp*P1**2)*P1
      e4=(2._dp*XYZ+e2*P1+3._dp*P1**3)*P1
      e5=XYZ*P1**2
      rj_c=6._dp*sum1+m1*Am**(-1.5_dp) &
              *(1._dp-e2*(C1+C5*e2-C3*E2)+C2*e3-C4*e4+C6*e5)
  end function rj_c

  function rj_r(x,y,z,p)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Future work: implement special case when x,y,z real and nonnegative   !
! with at most one allowed to be zero, and real(p)<=0.                  !
! Note case when x,y,z are complex has not been established (not dealt  !
! with in arxiv:math/9409227v1)                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      implicit none
      real(dp), intent(in) :: x,y,z,p
      real(dp) :: rj_r
      real(dp), parameter :: r=1.0e-4_dp
      real(dp), parameter :: C1=3._dp/14._dp, C2=1._dp/6._dp, C3=9._dp/88._dp
      real(dp), parameter :: C4=3._dp/22._dp, C5=9._dp/52._dp, C6=3._dp/26._dp
      real(dp) :: Q,m1
      real(dp) :: xm,ym,zm,pm,A0,delta,Am,lambm,dm,em
      real(dp) :: sqrtx,sqrty,sqrtz,sqrtp
      real(dp) :: X1,Y1,Z1,P1,XYZ,E2,E3,E4,E5
      real(dp) :: sum1,xarg,yarg
      ! Future work: implement special case when x,y,z real and nonnegative
      ! with at most one allowed to be zero, and real(p)<=0.
      ! Note case when x,y,z are complex has not been established (not dealt
      ! with in arxiv:math/9409227v1)
      if (real(p) <= 0.) then
          STOP 'need real(p)>0 for this implementation of Rj to work'
      else
          xm=x
          ym=y
          zm=z
          pm=p
      end if
      A0=(xm+ym+zm+2._dp*pm)*0.2_dp
      delta=(pm-xm)*(pm-ym)*(pm-zm)
      Q=(r*0.25_dp)**(-1._dp/6._dp) &
              * max(abs(A0-xm),abs(A0-ym),abs(A0-zm),abs(A0-pm))
      Am=A0
      m1=1._dp
      sum1=0._dp
      xarg=1._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          sqrtp=sqrt(pm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          dm=(sqrtp+sqrtx)*(sqrtp+sqrty)*(sqrtp+sqrtz)
          em=m1**3*delta/dm**2
          yarg=1._dp+em
          sum1=sum1+m1/dm*rc(xarg,yarg)
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          pm=0.25_dp*(pm+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      X1=(A0-x)*m1/Am
      Y1=(A0-y)*m1/Am
      Z1=(A0-z)*m1/Am
      P1=-0.5_dp*(X1+Y1+Z1)
      XYZ=X1*Y1*Z1
      e2=X1*Y1+X1*Z1+Y1*Z1-3._dp*P1**2
      e3=XYZ+2._dp*(e2+2._dp*P1**2)*P1
      e4=(2._dp*XYZ+e2*P1+3._dp*P1**3)*P1
      e5=XYZ*P1**2
      rj_r=6._dp*sum1+m1*Am**(-1.5_dp) &
              *(1._dp-e2*(C1+C5*e2-C3*E2)+C2*e3-C4*e4+C6*e5)
  end function rj_r

  function rd_c(x,y,z)
      implicit none
      complex(dp), intent(in) :: x,y,z
      complex(dp) :: rd_c
      real(dp), parameter :: r=1.0e-4_dp
      real(dp), parameter :: C1=3._dp/14._dp, C2=1._dp/6._dp, C3=9._dp/88._dp
      real(dp), parameter :: C4=3._dp/22._dp, C5=9._dp/52._dp, C6=3._dp/26._dp
      real(dp), parameter :: THIRD=1._dp/3._dp
      real(dp) :: Q,m1
      complex(dp) :: xm,ym,zm,A0,Am,lambm
      complex(dp) :: sqrtx,sqrty,sqrtz
      complex(dp) :: X1,Y1,Z1,e2,e3,e4,e5
      complex(dp) :: sum1
      A0=(x+y+3._dp*z)*0.2_dp
      xm=x
      ym=y
      zm=z
      Q=1._dp/(r*0.25_dp)**(1._dp/6._dp) &
              * max(abs(A0-xm),abs(A0-ym),abs(A0-zm))
      Am=A0
      m1=1._dp
      sum1=0._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          sum1=sum1+m1/(sqrtz*(zm+lambm))
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      X1=(A0-x)*m1/Am
      Y1=(A0-y)*m1/Am
      Z1=(-X1-Y1)*THIRD
      e2=X1*Y1-6._dp*Z1**2
      e3=(3._dp*X1*Y1-8._dp*Z1**2)*Z1
      e4=3._dp*(X1*Y1-Z1**2)*Z1**2
      e5=X1*Y1*Z1**3
      rd_c=3._dp*sum1+m1*Am**(-1.5_dp) &
              *(1._dp-e2*(C1+C5*e3-C3*e2)+C2*e3-C4*e4+C6*e5)
  end function rd_c

  function rd_r(x,y,z)
      implicit none
      real(dp), intent(in) :: x,y,z
      real(dp) :: rd_r
      real(dp), parameter :: r=1.0e-4_dp
      real(dp), parameter :: C1=3._dp/14._dp, C2=1._dp/6._dp, C3=9._dp/88._dp
      real(dp), parameter :: C4=3._dp/22._dp, C5=9._dp/52._dp, C6=3._dp/26._dp
      real(dp), parameter :: THIRD=1._dp/3._dp
      real(dp) :: Q,m1
      real(dp) :: xm,ym,zm,A0,Am,lambm
      real(dp) :: sqrtx,sqrty,sqrtz
      real(dp) :: X1,Y1,Z1,e2,e3,e4,e5
      real(dp) :: sum1
      A0=(x+y+3._dp*z)*0.2_dp
      xm=x
      ym=y
      zm=z
      Q=1._dp/(r*0.25_dp)**(1._dp/6._dp) &
              * max(abs(A0-xm),abs(A0-ym),abs(A0-zm))
      Am=A0
      m1=1._dp
      sum1=0._dp
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          sum1=sum1+m1/(sqrtz*(zm+lambm))
          Am=0.25_dp*(Am+lambm)
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          m1=m1*0.25_dp
          if (m1*Q < abs(Am)) exit
      end do
      X1=(A0-x)*m1/Am
      Y1=(A0-y)*m1/Am
      Z1=(-X1-Y1)*THIRD
      e2=X1*Y1-6._dp*Z1**2
      e3=(3._dp*X1*Y1-8._dp*Z1**2)*Z1
      e4=3._dp*(X1*Y1-Z1**2)*Z1**2
      e5=X1*Y1*Z1**3
      rd_r=3._dp*sum1+m1*Am**(-1.5_dp) &
              *(1._dp-e2*(C1+C5*e3-C3*e2)+C2*e3-C4*e4+C6*e5)
  end function rd_r

  function rf_c(x,y,z)
      implicit none
      complex(dp), intent(in) :: x,y,z
      complex(dp) :: rf_c
      real(dp), parameter :: ERRTOL=0.0025_dp
      real(dp), parameter :: a1=1._dp/24._dp,THIRD=1._dp/3._dp
      real(dp), parameter :: C2=0.1_dp,C3=3._dp/44._dp
      real(dp), parameter :: C4=1._dp/14._dp
      complex(dp) :: xm,ym,zm,Am,lambm
      complex(dp) :: sqrtx,sqrty,sqrtz
      complex(dp) :: delx,dely,delz,e2,e3
      xm=x
      ym=y
      zm=z
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          Am=THIRD*(xm+ym+zm)
          if (Am == 0._dp) then
              delx=0._dp
              dely=0._dp
              delz=0._dp
          else
              delx=(Am-xm)/Am
              dely=(Am-ym)/Am
              delz=(Am-zm)/Am
          endif
          if (max(abs(delx),abs(dely),abs(delz)) < ERRTOL) exit
      end do
      e2=delx*dely-delz*delz
      e3=delx*dely*delz
      rf_c=(1._dp+(a1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(Am)
  end function rf_c

  function rf_r(x,y,z)
      implicit none
      real(dp), intent(in) :: x,y,z
      real(dp) :: rf_r
      real(dp), parameter :: ERRTOL=0.0025_dp
      real(dp), parameter :: a1=1._dp/24._dp,THIRD=1._dp/3._dp
      real(dp), parameter :: C2=0.1_dp,C3=3._dp/44._dp
      real(dp), parameter :: C4=1._dp/14._dp
      real(dp) :: xm,ym,zm,Am,lambm
      real(dp) :: sqrtx,sqrty,sqrtz
      real(dp) :: delx,dely,delz,e2,e3
      xm=x
      ym=y
      zm=z
      do
          sqrtx=sqrt(xm)
          sqrty=sqrt(ym)
          sqrtz=sqrt(zm)
          lambm=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          xm=0.25_dp*(xm+lambm)
          ym=0.25_dp*(ym+lambm)
          zm=0.25_dp*(zm+lambm)
          Am=THIRD*(xm+ym+zm)
          if (Am == 0._dp) then
              delx=0._dp
              dely=0._dp
              delz=0._dp
          else
              delx=(Am-xm)/Am
              dely=(Am-ym)/Am
              delz=(Am-zm)/Am
          endif
          if (max(abs(delx),abs(dely),abs(delz)) < ERRTOL) exit
      end do
      e2=delx*dely-delz*delz
      e3=delx*dely*delz
      rf_r=(1._dp+(a1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(Am)
  end function rf_r

  double precision FUNCTION rf_2(x,y,z)
!************************************************************************
!     PURPOSE: Compute Carlson fundamental integral RF
!              R_F=1/2 \int_0^\infty dt (t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2)
!     ARGUMENTS: Symmetric arguments x,y,z
!     ROUTINES CALLED:  None.
!     ALGORITHM: Due to B.C. Carlson.
!     ACCURACY:  The parameter ERRTOL sets the desired accuracy.
!     REMARKS: Accepts real arguments only
!     AUTHOR:  Press et al (1992).
!     DATE WRITTEN:  25 Mar 91.
!     REVISIONS:
!**********************************************************************
      implicit none
      double precision x,y,z,ERRTOL,THIRD,a1,C2,C3,C4
      PARAMETER(ERRTOL=0.0025d0,THIRD=1.d0/3.d0, &
                    a1=1.d0/24.d0,C2=0.1d0,C3=3.d0/44.d0,C4=1.d0/14.d0)
      double precision alamb,ave,delx,dely,delz,e2,e3,sqrtx,sqrty, &
                    sqrtz,sqrt,xt,yt,zt
      xt=x
      yt=y
      zt=z
1     continue
      sqrtx=sqrt(xt)
      sqrty=sqrt(yt)
      sqrtz=sqrt(zt)
      alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
      xt=0.25d0*(xt+alamb)
      yt=0.25d0*(yt+alamb)
      zt=0.25d0*(zt+alamb)
      ave=THIRD*(xt+yt+zt)
      if(ave.eq.0.d0) then
          delx=0.d0
          dely=0.d0
          delz=0.d0
      else
          delx=(ave-xt)/ave
          dely=(ave-yt)/ave
          delz=(ave-zt)/ave
      endif
      if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)go to 1
      e2=delx*dely-delz*delz
      e3=delx*dely*delz
      rf_2=(1.d0+(a1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(ave)
      return
  END FUNCTION rf_2

  FUNCTION rd_2(x,y,z)
!**********************************************************************
!     PURPOSE: Compute Carlson degenerate integral RD
!              R_D(x,y,z)=3/2 \int_0^\infty dt (t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-3/2)
!     ARGUMENTS: x,y,z
!     ROUTINES CALLED:  None.
!     ALGORITHM: Due to B.C. Carlson.
!     ACCURACY:  The parameter ERRTOL sets the desired accuracy.
!     REMARKS: An earlier algorithm of Carlson 1994
!     AUTHOR:  Press et al (1992)
!     DATE WRITTEN:  25 Mar 91.
!     REVISIONS:
!**********************************************************************
      complex(dp), intent(in) :: x,y,z
      complex(dp) :: rd_2
      real(dp), parameter :: ERRTOL=0.0015_dp,a1=3._dp/14._dp,C2=1._dp/6._dp, &
              C3=9._dp/22._dp,C4=3._dp/26._dp,C5=0.25_dp*C3,C6=1.5_dp*C4
      complex(dp) :: alamb,ave,delx,dely,delz,ea,eb,ec,ed,ee,fac,sqrtx,sqrty, &
              sqrtz,sum,xt,yt,zt
      xt=x
      yt=y
      zt=z
      sum=0._dp
      fac=1._dp
      do
          sqrtx=sqrt(xt)
          sqrty=sqrt(yt)
          sqrtz=sqrt(zt)
          alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
          sum=sum+fac/(sqrtz*(zt+alamb))
          fac=0.25_dp*fac
          xt=.25_dp*(xt+alamb)
          yt=.25_dp*(yt+alamb)
          zt=.25_dp*(zt+alamb)
          ave=.2_dp*(xt+yt+3._dp*zt)
          delx=(ave-xt)/ave
          dely=(ave-yt)/ave
          delz=(ave-zt)/ave
          if(max(abs(delx),abs(dely),abs(delz)).lt.ERRTOL) exit
      end do
      ea=delx*dely
      eb=delz*delz
      ec=ea-eb
      ed=ea-6._dp*eb
      ee=ed+ec+ec
      rd_2=3._dp*sum+fac*(1._dp+ed*(-a1+C5*ed-C6*delz*ee) &
              +delz*(C2*ee+delz*(-C3*ec+delz*C4*ea)))/(ave*sqrt(ave))
  END FUNCTION rd_2

  subroutine dopri_stepper(ode,h,ti,to,k,yi,yo,dyi,dyo,err,atol,rtol)
      implicit none
      real(dp), intent(in) :: h,ti,atol,rtol
      real(dp), dimension(:), intent(in) :: yi,dyi
      real(dp), dimension(size(yi)), intent(out) :: yo,dyo
      real(dp), dimension(7,size(yi)), intent(out) :: k
      real(dp), dimension(size(yi)) :: y,dy,del,del0
      real(dp), intent(out) :: to,err
      real(dp) :: t
      integer :: Neq,j
      interface
          subroutine ode(t,y,dy)
              use precision1
              implicit none
              real(dp), intent(in) :: t
              real(dp), dimension(:), intent(in) :: y
              real(dp), dimension(size(y)), intent(out) :: dy
          end subroutine ode
      end interface
      real(dp), parameter :: &
              C2=0.2_dp,&
              C3=0.3_dp,&
              C4=0.8_dp,&
              C5=8._dp/9._dp,&
              A21=0.2_dp,&
              A31=3._dp/40._dp,&
              A32=9._dp/40._dp,&
              A41=44._dp/45._dp,&
              A42=-56._dp/15._dp,&
              A43=32._dp/9._dp,&
              A51=19372._dp/6561._dp,&
              A52=-25360._dp/2187._dp,&
              A53=64448._dp/6561._dp,&
              A54=-212._dp/729._dp,&
              A61=9017._dp/3168._dp,&
              A62=-355._dp/33._dp,&
              A63=46732._dp/5247._dp,&
              A64=49._dp/176._dp,&
              A65=-5103._dp/18656._dp,&
              A71=35._dp/384._dp,&
              A73=500._dp/1113._dp,&
              A74=125._dp/192._dp,&
              A75=-2187._dp/6784._dp,&
              A76=11._dp/84._dp,&
              E1=71._dp/57600._dp,&
              E3=-71._dp/16695._dp,&
              E4=71._dp/1920._dp,&
              E5=-17253._dp/339200._dp,&
              E6=22._dp/525._dp,&
              E7=-1._dp/40._dp
      Neq=size(yi)
      k(1,:)=h*dyi
! second piece
      t=ti+C2*h
      y=yi+A21*k(1,:)
      call ode(t,y,dy)
      k(2,:)=h*dy
! third
      t=ti+C3*h
      y=yi+A31*k(1,:)+A32*k(2,:)
      call ode(t,y,dy)
      k(3,:)=h*dy
! fourth
      t=ti+C4*h
      y=yi+A41*k(1,:)+A42*k(2,:)+A43*k(3,:)
      call ode(t,y,dy)
      k(4,:)=h*dy
! fifth
      t=ti+C5*h
      y=yi+A51*k(1,:)+A52*k(2,:)+A53*k(3,:) &
              +A54*k(4,:)
      call ode(t,y,dy)
      k(5,:)=h*dy
! sixth
      t=ti+h
      y=yi+A61*k(1,:)+A62*k(2,:)+A63*k(3,:) &
              +A64*k(4,:)+A65*k(5,:)
      call ode(t,y,dy)
      k(6,:)=h*dy
! seventh and last
      to=ti+h
      yo=yi+A71*k(1,:)+A73*k(3,:)+A74*k(4,:) &
              +A75*k(5,:)+A76*k(6,:) !final
! estimate the local error
      call ode(to,yo,dyo) !FSAL
      k(7,:)=h*dyo
      del=E1*k(1,:)+E3*k(3,:)+E4*k(4,:) &
              +E5*k(5,:)+E6*k(6,:)+E7*k(7,:)
      do j=1,Neq
          del0(j)=atol+rtol*max(abs(yo(j)),abs(yi(j)))
      end do
      err=0._dp
      do j=1,Neq
          err=err+(del(j)/del0(j))**2
      end do
      err=sqrt(err/(1._dp*Neq))
  end subroutine dopri_stepper

  function ydout(h,t1,tout,k,y1,y2)
      ! Dense output, error is O(h^5)
      implicit none
      real(dp) :: h,t1,tout,theta,theta1
      real(dp), dimension(:), intent(in) :: y1,y2
      real(dp), dimension(7,size(y1)), intent(in) :: k
      real(dp), dimension(size(y1)) :: con1,con2,con3,con4,con5
      real(dp), dimension(size(y1)) :: dy,ydout
      real(dp), parameter :: &
              D1=-12715105075._dp/11282082432._dp,     &
              D3=87487479700._dp/32700410799._dp,      &
              D4=-10690763975._dp/1880347072._dp,      &
              D5=701980252875._dp/199316789632._dp,    &
              D6=-1453857185._dp/822651844._dp,        &
              D7=69997945._dp/29380423._dp
      !Interpolating polynomial. Returns y between y1 and y2 at tout
      !   NOTE: our k1,k2 etc include h in them hence why
      !         our con5 is not multiplied by h while in
      !         Numerical Recipes (2007) it is.
      dy=y2-y1
      con1=y1
      con2=dy
      con3=k(1,:)-dy
      con4=dy-k(7,:)-con3
      con5=D1*k(1,:)+D3*k(3,:)+D4*k(4,:) &
              +D5*k(5,:)+D6*k(6,:)+D7*k(7,:)
      theta=(tout-t1)/h
      theta1=1._dp-theta
      ydout=con1+theta*(con2+theta1*(con3 &
              +theta*(con4+theta1*con5)))
  end function ydout

  subroutine controller(err,errold,reject,h)
      implicit none
      logical :: reject
      real(dp) :: err,errold,h,scale,safe
      real(dp) :: maxscale,minscale,alpha,beta
      safe=0.9_dp
      minscale=0.2_dp
      maxscale=10._dp
      beta=0.02_dp !0._dp
      alpha=0.2_dp - beta*0.75_dp
      if (err <= 1._dp) then
          if (err == 0._dp) then
              scale=maxscale
          else
              scale=safe*(1._dp/(err**alpha))*errold**beta
              if(scale < minscale) scale=minscale
              if(scale > maxscale) scale=maxscale
          endif
          if (reject) then
              h=h*min(scale, 1._dp)
          else
              h=h*scale
          endif
          errold=max(err, 1e-4_dp)
          reject=.false.
      else
          scale=max(safe*(1._dp/err)**alpha, minscale)
          h=h*scale
          reject=.true.
      endif
  end subroutine controller

  subroutine ang2vec(theta,phi,vector)
!***********************************************************************
!     PURPOSE: renders the vector (x,y,z) corresponding to angles
!              theta (co-latitude measured from North pole, in [0,Pi] radians)
!              and phi (longitude measured eastward, in radians)
!              North pole is (x,y,z)=(0,0,1)
!     ARGUMENTS: theta,phi
!     ROUTINES CALLED:
!     ALGORITHM:
!     ACCURACY:
!     REMARKS: adapted from Healpix library v3.30
!     AUTHOR:  Gorski et al. (2013)
!     DATE WRITTEN:  Feb 2000
!     REVISIONS:
!**********************************************************************
      use constants, only : PI
      implicit none
      real(dp), intent(in) :: theta,phi
      real(dp), intent(out), dimension(3) :: vector
      if (theta<0.0_dp .or. theta>PI) then
          print *, 'ang2vec: theta : ',theta,' is out of range [0, Pi]'
          STOP
      end if
      vector(1)=sin(theta)*cos(phi)
      vector(2)=sin(theta)*sin(phi)
      vector(3)=cos(theta)
      return
  end subroutine ang2vec

  subroutine vec2ang(vector,theta,phi)
!***********************************************************************
!     PURPOSE: renders the angles theta, phi corresponding to vector (x,y,z)
!              theta (co-latitude measured from North pole, in [0,Pi] radians)
!              and phi (longitude measured eastward, in [0,2Pi[ radians)
!              North pole is (x,y,z)=(0,0,1)
!     ARGUMENTS: vector
!     ROUTINES CALLED:
!     ALGORITHM:
!     ACCURACY:
!     REMARKS: adapted from Healpix library v3.30
!     AUTHOR:  Gorski et al. (2013)
!     DATE WRITTEN:  Feb 2000
!     REVISIONS: 2011-08
!**********************************************************************
      use constants, only : PI
      implicit none
      real(dp), intent(in), dimension(3) :: vector
      real(dp), intent(out) :: theta,phi
      theta=atan2(sqrt(vector(1)**2+vector(2)**2), vector(3))
      phi=0._dp
      if (vector(1) /= 0._dp .or. vector(2) /= 0._dp) &
              phi=atan2(vector(2),vector(1)) ! phi in ]-pi,pi]
      if (phi < 0._dp) phi=phi+2._dp*PI ! phi in [0,2pi[
      return
  end subroutine vec2ang

  subroutine rotate(vector,psi,axis)
      implicit none
      real(dp), intent(inout) :: vector(3)
      real(dp), intent(in) :: psi
      character(len=1), intent(in) :: axis
      real(dp), parameter :: ze=0._dp,on=1._dp
      real(dp), dimension(3,3) :: m1,m2,m3
      real(dp) :: c1,s1
      c1=cos(psi)
      s1=sin(psi)
      select case (axis)
      case ('x')
          m3(:,1)=(/ on, ze, ze /)
          m3(:,2)=(/ ze, c1, s1 /)
          m3(:,3)=(/ ze,-s1, c1 /)
          vector=matmul(m3,vector)
      case ('y')
          m2(:,1)=(/ c1, ze, s1 /)
          m2(:,2)=(/ ze, on, ze /)
          m2(:,3)=(/-s1, ze, c1 /)
          vector=matmul(m2,vector)
      case ('z')
          m1(:,1)=(/ c1, s1, ze /)
          m1(:,2)=(/-s1, c1, ze /)
          m1(:,3)=(/ ze, ze, on /)
          vector=matmul(m1,vector)
      case default
          STOP 'axis must be either ''x'',''y'' or ''z'''
      end select
  end subroutine rotate

END MODULE utils


include '../../src/sort_mod.f90'

program test_sort
use sort_mod
implicit none
    integer                 :: k1                   ! iterator
    double precision        :: tda1(10), tda2(10), tda3(10)   ! double arrays
    integer                 :: tia1(8), tia2(8)     ! integer arrays
    integer, allocatable    :: sid(:), sii(:)       ! sort_inds

    double precision, allocatable   :: unique_arr(:)
    double precision                :: unique_tol = 1.d-1

    logical             :: test_failed = .false.

    tda1 = [0.45933988, 0.85925698, 0.19866538, 0.19590951, 0.26951959, &
            0.21166847, 0.58193321, 0.54999474, 0.74012868, 0.58838597]
    tda2 = tda1

    tia1 = [14, -56, 86, 3, 94, -44, -55, -68]
    tia2 = tia1

    call sortinds(tda1, sid)
    ! Check that sortinds does not have any side effects
    if (.not.all(tda1==tda2)) then
        write(*,*) 'sortinds affected original double array'
        test_failed = .true.
    endif
    call sort(tda1)
    ! Check that sorted array is (weakly) ascending
    do k1=2,size(tda1)
        if (tda1(k1-1) > tda1(k1)) then
            write(*,*) 'sorted dbl array not at least weakly ascending'
            test_failed = .true.
        endif
    enddo
    ! Check that sortinds and sort produces the same results
    if (.not.all(tda1==tda2(sid))) then
        write(*,*) 'sortinds does not give the same order of elements as sort (dbl)'
        test_failed = .true.
    endif

    call sortinds(tia1, sii)
    ! Check that sortinds does not have any side effects
    if (.not.all(tia1==tia2)) then
        write(*,*) 'sortinds affected original int array'
        test_failed = .true.
    endif
    call sort(tia1)
    ! Check that sorted array is (weakly) ascending
    do k1=2,size(tia1)
        if (tia1(k1-1) > tia1(k1)) then
            write(*,*) 'sorted int array not at least weakly ascending'
            test_failed = .true.
        endif
    enddo

    ! Check that sortinds and sort produces the same results
    if (.not.all(tia1==tia2(sii))) then
        write(*,*) 'sortinds does not give the same order of elements as sort (dbl)'
        test_failed = .true.
    endif

    ! Test unique
    tda3=tda2
    call unique(tda2, unique_arr, unique_tol)
    do k1=2,size(unique_arr)
        if (unique_arr(k1)<=unique_arr(k1-1)) then
            write(*,*) 'unique array not strictly ascending'
            test_failed = .true.
        endif
    enddo
    if (any(tda2/=tda3)) then
        write(*,*) 'unique modified the passed in array'
        test_failed = .true.
    endif

    if (test_failed) then
        error stop 1
    else
        stop 0
    endif

end program


! **********************************************************************************
!>    Module Point3D
! **********************************************************************************
      module Point3dMod
         implicit none
         save

         type :: Point3d
            real:: x, y, z
         contains
            procedure, pass :: writePoint3d
         end type Point3d

         interface Point3d
            module procedure createPoint3d
         end interface

         !interface
         !   subroutine writePoint3d(pt)
         !      import Point3d
         !      class(Point3d) :: pt
         !   end subroutine
         !end interface

         contains
! **********************************************************************************
         type(Point3d) function createPoint3d(a,b,c) result(pt)
! **********************************************************************************
         real,intent(in)  :: a,b,c

         pt%x = a
         pt%y = b
         pt%z = c

         end function ! createPoint3d

! **********************************************************************************
         subroutine writePoint3d(this)
! **********************************************************************************
            class(Point3d), intent(in) :: this
            write(*, *) "********** Point3D **********"
            write(*, *) '(', this%x,',', this%y, ',', this%z,')'
         end subroutine

      end module Point3dMod

! **********************************************************************************
!>    Module Line
! **********************************************************************************
      module LineMod
         use Point3dMod
         implicit none
         save

         type :: Line
            type(Point3d):: p0, p1
         contains
            procedure, pass :: writeLine
         end type Line

         interface Line
            module procedure createLine
         end interface

         contains
! **********************************************************************************
         type(Line) function createLine(a,b) result(ln)
! **********************************************************************************
         type(Point3d),intent(in)  :: a,b

         ln%p0 = a
         ln%p1 = b

         end function ! createLine

! **********************************************************************************
         subroutine writeLine(this)
! **********************************************************************************
            class(Line), intent(inout) :: this
            write(*, *) "********** Line **********"
            call this%p0%writePoint3d()
            call this%p1%writePoint3d()
         end subroutine

      end module LineMod


!!# SUBROUTINE MODULE: <SUB_genQuadrature_FROM_lev>
MODULE SUB_genQuadrature_FROM_lev
!!## PURPOSE
!! Return a general quadrature set on the unit
!! sphere from a "level symmetric" (lev) quadrature
!! where there is rotational invariance with respect to
!! 90 degree rotations.

!!## EXTERNAL PROCEDURES
USE FUN_SIZEa                                 !!((06-B-FUN_SIZEa.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE genQuadrature_FROM_lev
 MODULE PROCEDURE genQuadrature_FROM_lev_Rsp
 MODULE PROCEDURE genQuadrature_FROM_lev_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: genQuadrature_FROM_lev

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: genQuadrature_FROM_lev_Rsp
PURE SUBROUTINE genQuadrature_FROM_lev_Rsp( xa , xp , wa , wp , &
                                   m_map , x , w , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_genQuadrature_FROM_lev.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_genQuadrature_FROM_lev.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: genQuadrature_FROM_lev_Rdp
PURE SUBROUTINE genQuadrature_FROM_lev_Rdp( xa , xp , wa , wp , &
                                   m_map , x , w , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_genQuadrature_FROM_lev.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_genQuadrature_FROM_lev.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


! ---------------------- BEGIN MNMAXIDX ----------------------
      subroutine mnmaxidx(a,nstrt,nstop,ninc,
     :                    amin,amax,indx_min,indx_max)

! A rewrite of mnmax, returning the indices of the min and max values
!
! Dates: 10/05/99 - written by D. M. Boore
!        05/16/02 - Replaced "dimension a(1)" with "real a(*)"
!        11/03/12 - Replace if-then with if--then-else

      real a(*)
      amax = a( nstrt)
      indx_max = nstrt
      amin=amax
      indx_min = nstrt
      do i=nstrt,nstop,ninc

        if (a(i) > amax) then
          amax=a(i)
          indx_max = i
        else if (a(i) < amin) then
          amin=a(i)
          indx_min = i
        end if

      end do

      return
      end
! ---------------------- END MNMAXIDX ----------------------


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 57071 - Check that 1**k is transformed into 1
program main
  implicit none
  integer, parameter :: n = 3
  integer(kind=8), dimension(-n:n) :: a
  integer, dimension(-n:n) :: c, d
  integer :: m
  integer :: i, v
  integer (kind=2) :: i2

  v = 1
  m = n
  ! Test in scalar expressions
  do i=-n,n
     if (v /= 1**i) STOP 1
  end do

  ! Test in array constructors
  a(-m:m) = [ (1**i, i= -m, m) ]
  if (any(a .ne. v)) STOP 2

  ! Test in array expressions
  c = [ ( i, i = -n , n ) ]
  d = 1**c
  if (any(d .ne. v)) STOP 3

  ! Test in different kind expressions
  do i2=-n,n
     if (v /= 1**i2) STOP 4
  end do

end program main
! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 0 "original" } }


!*==sscal.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b SSCAL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSCAL(N,SA,SX,INCX)
!
!       .. Scalar Arguments ..
!       REAL SA
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       REAL SX(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    SSCAL scales a vector by a constant.
!>    uses unrolled loops for increment equal to 1.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] SA
!> \verbatim
!>          SA is REAL
!>           On entry, SA specifies the scalar alpha.
!> \endverbatim
!>
!> \param[in,out] SX
!> \verbatim
!>          SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of SX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 3/93 to return if incx .le. 0.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SSCAL(N,Sa,Sx,Incx)
      IMPLICIT NONE
!*--SSCAL83
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      REAL Sa
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      REAL Sx(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , m , mp1 , nincx
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MOD
!     ..
      IF ( N<=0 .OR. Incx<=0 ) RETURN
      IF ( Incx==1 ) THEN
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
         m = MOD(N,5)
         IF ( m/=0 ) THEN
            DO i = 1 , m
               Sx(i) = Sa*Sx(i)
            ENDDO
            IF ( N<5 ) RETURN
         ENDIF
         mp1 = m + 1
         DO i = mp1 , N , 5
            Sx(i) = Sa*Sx(i)
            Sx(i+1) = Sa*Sx(i+1)
            Sx(i+2) = Sa*Sx(i+2)
            Sx(i+3) = Sa*Sx(i+3)
            Sx(i+4) = Sa*Sx(i+4)
         ENDDO
      ELSE
!
!        code for increment not equal to 1
!
         nincx = N*Incx
         DO i = 1 , nincx , Incx
            Sx(i) = Sa*Sx(i)
         ENDDO
      ENDIF
      END SUBROUTINE SSCAL


      double complex function D3six(k1,k2,k3,k4,k5,k6)
      implicit none
C----- six dimensional box corresponding to
C----- qlI4(s56,0d0,s34,0d0,s156,s134,0d0,mtsq,mtsq,0d0,musq,e)
C----- multiplied by a factor of -C(0)/2
      include 'constants.f'
      include 'masses.f'
      include 'scale.f'
      include 'sprods_com.f'
      integer k1,k2,k3,k4,k5,k6
      double complex qlI4,qlI3,IntC(4),IntD
      double precision s12,s34,s56,s134,s156,C(0:4),mtsq,Delta
      integer e
      mtsq=mt**2
      s12=s(k1,k2)
      s34=s(k3,k4)
      s56=s(k5,k6)
      s134=s(k1,k3)+s(k1,k4)+s(k3,k4)
      s156=s(k1,k5)+s(k1,k6)+s(k5,k6)
      Delta=s12*mtsq-s34*s56+s134*s156
      C(1)=2d0*(s134-s34)*(2d0*s12*mtsq-Delta)/Delta**2
      C(2)=2d0*(s34-s156)/Delta
      C(3)=2d0*(s56-s134)/Delta
      C(4)=2d0*(s156-s56)*(2d0*s12*mtsq-Delta)/Delta**2
      C(0)=4d0*s12*(s134*s156-s34*s56)/Delta**2
      e=0
      IntC(1)=qlI3(s134,0d0,s34,0d0,mtsq,mtsq,musq,e)    !C7
      IntC(2)=qlI3(0d0,s34,s156,0d0,0d0,mtsq,musq,e)     !C5
      IntC(3)=qlI3(0d0,s56,s134,0d0,0d0,mtsq,musq,e)     !C3
      IntC(4)=qlI3(s156,0d0,s56,0d0,mtsq,mtsq,musq,e)    !C9
      IntD=qlI4(s56,0d0,s34,0d0,s156,s134,0d0,mtsq,mtsq,0d0,musq,e)
      D3six=0.5d0*(C(1)*IntC(1)+C(2)*IntC(2)+C(3)*IntC(3)+C(4)*IntC(4)
     & +2d0*IntD)

C---debug
c---real six dim box
c      D3six=-(C(1)*IntC(1)+C(2)*IntC(2)+C(3)*IntC(3)+C(4)*IntC(4)
c     & +2d0*IntD)/C(0)
C---debug
      return
      end


!  This MODULE holds the routines that calculate air-sea exchange coefficients

MODULE module_sf_exchcoef
CONTAINS

  SUBROUTINE znot_m_v1(uref,znotm)
  IMPLICIT NONE

! uref(m/s)   :   Reference level wind
! znotm(meter):   Roughness scale for momentum
! Author      :  Biju Thomas on 02/07/2014
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znotm
    REAL             :: bs0, bs1, bs2, bs3, bs4, bs5, bs6
    REAL             :: cf0, cf1, cf2, cf3, cf4, cf5, cf6

    bs0 = -8.367276172397277e-12
    bs1 = 1.7398510865876079e-09
    bs2 = -1.331896578363359e-07
    bs3 = 4.507055294438727e-06
    bs4 = -6.508676881906914e-05
    bs5 = 0.00044745137674732834
    bs6 = -0.0010745704660847233

    cf0 = 2.1151080765239772e-13
    cf1 = -3.2260663894433345e-11
    cf2 = -3.329705958751961e-10
    cf3 = 1.7648562021709124e-07
    cf4 = 7.107636825694182e-06
    cf5 = -0.0013914681964973246
    cf6 = 0.0406766967657759

    IF ( uref .LE. 5.0 ) THEN
      znotm = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2)
    ELSEIF (uref .GT. 5.0 .AND. uref .LT. 10.0) THEN
      znotm =.00000235*(uref**2 - 25 ) + 3.805129199617346e-05
    ELSEIF ( uref .GE. 10.0  .AND. uref .LT. 60.0) THEN
      znotm = bs6 + bs5*uref + bs4*uref**2 + bs3*uref**3 + bs2*uref**4 +  &
              bs1*uref**5 + bs0*uref**6
    ELSE
      znotm = cf6 + cf5*uref + cf4*uref**2 + cf3*uref**3 + cf2*uref**4 +  &
              cf1*uref**5 + cf0*uref**6

    END IF

  END SUBROUTINE znot_m_v1

  SUBROUTINE znot_m_v0(uref,znotm)
  IMPLICIT NONE

! uref(m/s)   :   Reference level wind
! znotm(meter):   Roughness scale for momentum
! Author      :  Biju Thomas on 02/07/2014

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znotm
    REAL             :: yz, y1, y2, y3, y4

    yz =  0.0001344
    y1 =  3.015e-05
    y2 =  1.517e-06
    y3 = -3.567e-08
    y4 =  2.046e-10

    IF ( uref .LT. 12.5 ) THEN
       znotm  = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2)
    ELSE IF ( uref .GE. 12.5 .AND. uref .LT. 30.0 ) THEN
       znotm = (0.0739793 * uref -0.58)/1000.0
    ELSE
       znotm = yz + uref*y1 + uref**2*y2 + uref**3*y3 + uref**4*y4
    END IF

  END SUBROUTINE znot_m_v0

  SUBROUTINE znot_t_v1(uref,znott)
  IMPLICIT NONE

! uref(m/s)   :   Reference level wind
! znott(meter):   Roughness scale for temperature/moisture
! Author      :  Biju Thomas on 02/07/2014

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znott
    REAL             :: to0, to1, to2, to3
    REAL             :: tr0, tr1, tr2, tr3
    REAL             :: tn0, tn1, tn2, tn3, tn4, tn5
    REAL             :: ta0, ta1, ta2, ta3, ta4, ta5, ta6
    REAL             :: tt0, tt1, tt2, tt3, tt4, tt5, tt6, tt7

    tr0 = 6.451939325286488e-08
    tr1 = -7.306388137342143e-07
    tr2 = -1.3709065148333262e-05
    tr3 = 0.00019109962089098182

    to0 = 1.4379320027061375e-08
    to1 = -2.0674525898850674e-07
    to2 = -6.8950970846611e-06
    to3 = 0.00012199648268521026

    tn0 = 1.4023940955902878e-10
    tn1 = -1.4752557214976321e-08
    tn2 = 5.90998487691812e-07
    tn3 = -1.0920804077770066e-05
    tn4 = 8.898205876940546e-05
    tn5 = -0.00021123340439418298

    tt0 = 1.92409564131838e-12
    tt1 = -5.765467086754962e-10
    tt2 = 7.276979099726975e-08
    tt3 = -5.002261599293387e-06
    tt4 = 0.00020220445539973736
    tt5 = -0.0048088230565883
    tt6 = 0.0623468551971189
    tt7 = -0.34019193746967424

    ta0 = -1.7787470700719361e-10
    ta1 = 4.4691736529848764e-08
    ta2 = -3.0261975348463414e-06
    ta3 = -0.00011680322286017206
    ta4 = 0.024449377821884846
    ta5 = -1.1228628619105638
    ta6 = 17.358026773905973

    IF ( uref .LE. 7.0 ) THEN
      znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2)
    ELSEIF ( uref  .GE. 7.0 .AND. uref .LT. 12.5 ) THEN
      znott =  tr3 + tr2*uref + tr1*uref**2 + tr0*uref**3
    ELSEIF ( uref  .GE. 12.5 .AND. uref .LT. 15.0 ) THEN
      znott =  to3 + to2*uref + to1*uref**2 + to0*uref**3
    ELSEIF ( uref .GE. 15.0  .AND. uref .LT. 30.0) THEN
      znott =  tn5 + tn4*uref + tn3*uref**2 + tn2*uref**3 + tn1*uref**4 +   &
                                                       tn0*uref**5
    ELSEIF ( uref .GE. 30.0  .AND. uref .LT. 60.0) THEN
      znott = tt7 + tt6*uref + tt5*uref**2  + tt4*uref**3 + tt3*uref**4 +   &
             tt2*uref**5 + tt1*uref**6 + tt0*uref**7
    ELSE
      znott =  ta6 + ta5*uref + ta4*uref**2  + ta3*uref**3 + ta2*uref**4 +  &
              ta1*uref**5 + ta0*uref**6
    END IF

  END SUBROUTINE znot_t_v1

  SUBROUTINE znot_t_v0(uref,znott)
  IMPLICIT NONE

! uref(m/s)   :   Reference level wind
! znott(meter):   Roughness scale for temperature/moisture
! Author      :  Biju Thomas on 02/07/2014

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znott

    IF ( uref .LT. 7.0 ) THEN
       znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2)
    ELSE
       znott = (0.2375*exp(-0.5250*uref) + 0.0025*exp(-0.0211*uref))*0.01
    END IF

  END SUBROUTINE znot_t_v0

  SUBROUTINE znot_t_v2(uu,znott)
  IMPLICIT NONE

! uu in MKS
! znott in m
! Biju Thomas on 02/12/2015
!

    REAL, INTENT(IN) :: uu
    REAL, INTENT(OUT):: znott
    REAL             :: ta0, ta1, ta2, ta3, ta4, ta5, ta6
    REAL             :: tb0, tb1, tb2, tb3, tb4, tb5, tb6
    REAL             :: tt0, tt1, tt2, tt3, tt4, tt5, tt6

    ta0 = 2.51715926619e-09
    ta1 = -1.66917514012e-07
    ta2 = 4.57345863551e-06
    ta3 = -6.64883696932e-05
    ta4 = 0.00054390175125
    ta5 = -0.00239645231325
    ta6 = 0.00453024927761

    tb0 = -1.72935914649e-14
    tb1 = 2.50587455802e-12
    tb2 = -7.90109676541e-11
    tb3 = -4.40976353607e-09
    tb4 = 3.68968179733e-07
    tb5 = -9.43728336756e-06
    tb6 = 8.90731312383e-05

    tt0 = 4.68042680888e-14
    tt1 = -1.98125754931e-11
    tt2 = 3.41357133496e-09
    tt3 = -3.05130605309e-07
    tt4 = 1.48243563819e-05
    tt5 = -0.000367207751936
    tt6 = 0.00357204479347

    IF ( uu .LE. 7.0 ) THEN
       znott = (0.0185 / 9.8*(7.59e-4*uu**2+2.46e-2*uu)**2)
    ELSEIF ( uu  .GE. 7.0 .AND. uu .LT. 15. ) THEN
       znott = ta6 + ta5*uu + ta4*uu**2  + ta3*uu**3 + ta2*uu**4 +     &
               ta1*uu**5 + ta0*uu**6
    ELSEIF ( uu .GE. 15.0  .AND. uu .LT. 60.0) THEN
       znott = tb6 + tb5*uu + tb4*uu**2 + tb3*uu**3 + tb2*uu**4 +      &
               tb1*uu**5 + tb0*uu**6
    ELSE
       znott = tt6 + tt5*uu + tt4*uu**2  + tt3*uu**3 + tt2*uu**4 +    &
               tt1*uu**5 + tt0*uu**6
    END IF

  END SUBROUTINE znot_t_v2

  SUBROUTINE znot_m_v6(uref,znotm)
  IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
! For high winds, try to fit available observational data
!
! Bin Liu, NOAA/NCEP/EMC 2017
!
! uref(m/s)   :   wind speed at 10-m height
! znotm(meter):   areodynamical roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znotm
    REAL             :: p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p40

    p13 = -1.296521881682694e-02
    p12 =  2.855780863283819e-01
    p11 = -1.597898515251717e+00
    p10 = -8.396975715683501e+00

    p25 =  3.790846746036765e-10
    p24 =  3.281964357650687e-09
    p23 =  1.962282433562894e-07
    p22 = -1.240239171056262e-06
    p21 =  1.739759082358234e-07
    p20 =  2.147264020369413e-05

    p35 =  1.840430200185075e-07
    p34 = -2.793849676757154e-05
    p33 =  1.735308193700643e-03
    p32 = -6.139315534216305e-02
    p31 =  1.255457892775006e+00
    p30 = -1.663993561652530e+01

    p40 =  4.579369142033410e-04

    if (uref >= 0.0 .and.  uref <= 6.5 ) then
      znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3)
    elseif (uref > 6.5 .and. uref <= 15.7) then
      znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 15.7 .and. uref <= 53.0) then
      znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 )
    elseif ( uref > 53.0) then
      znotm = p40
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_m_v6

  SUBROUTINE znot_t_v6(uref,znott)
  IMPLICIT NONE
! Calculate scalar roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF
!
! Bin Liu, NOAA/NCEP/EMC 2017
!
! uref(m/s)   :   wind speed at 10-m height
! znott(meter):   scalar roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znott

    REAL             :: p00
    REAL             :: p15, p14, p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p45, p44, p43, p42, p41, p40
    REAL             :: p56, p55, p54, p53, p52, p51, p50
    REAL             :: p60

    p00 =  1.100000000000000e-04

    p15 = -9.144581627678278e-10
    p14 =  7.020346616456421e-08
    p13 = -2.155602086883837e-06
    p12 =  3.333848806567684e-05
    p11 = -2.628501274963990e-04
    p10 =  8.634221567969181e-04

    p25 = -8.654513012535990e-12
    p24 =  1.232380050058077e-09
    p23 = -6.837922749505057e-08
    p22 =  1.871407733439947e-06
    p21 = -2.552246987137160e-05
    p20 =  1.428968311457630e-04

    p35 =  3.207515102100162e-12
    p34 = -2.945761895342535e-10
    p33 =  8.788972147364181e-09
    p32 = -3.814457439412957e-08
    p31 = -2.448983648874671e-06
    p30 =  3.436721779020359e-05

    p45 = -3.530687797132211e-11
    p44 =  3.939867958963747e-09
    p43 = -1.227668406985956e-08
    p42 = -1.367469811838390e-05
    p41 =  5.988240863928883e-04
    p40 = -7.746288511324971e-03

    p56 = -1.187982453329086e-13
    p55 =  4.801984186231693e-11
    p54 = -8.049200462388188e-09
    p53 =  7.169872601310186e-07
    p52 = -3.581694433758150e-05
    p51 =  9.503919224192534e-04
    p50 = -1.036679430885215e-02

    p60 =  4.751256171799112e-05

    if (uref >= 0.0 .and. uref < 5.9 ) then
      znott = p00
    elseif (uref >= 5.9 .and. uref <= 15.4) then
      znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10
    elseif (uref > 15.4 .and. uref <= 21.6) then
      znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 21.6 .and. uref <= 42.2) then
      znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30
    elseif ( uref > 42.2 .and. uref <= 53.3) then
      znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40
    elseif ( uref > 53.3 .and. uref <= 80.0) then
      znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50
    elseif ( uref > 80.0) then
      znott = p60
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_t_v6

  SUBROUTINE znot_m_v7(uref,znotm)
  IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
! For high winds, try to fit available observational data
! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znotm(meter):   areodynamical roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znotm
    REAL             :: p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p40

    p13 = -1.296521881682694e-02
    p12 =  2.855780863283819e-01
    p11 = -1.597898515251717e+00
    p10 = -8.396975715683501e+00

    p25 =  3.790846746036765e-10
    p24 =  3.281964357650687e-09
    p23 =  1.962282433562894e-07
    p22 = -1.240239171056262e-06
    p21 =  1.739759082358234e-07
    p20 =  2.147264020369413e-05

    p35 =  1.897534489606422e-07
    p34 = -3.019495980684978e-05
    p33 =  1.931392924987349e-03
    p32 = -6.797293095862357e-02
    p31 =  1.346757797103756e+00
    p30 = -1.707846930193362e+01

    p40 =  3.371427455376717e-04

    if (uref >= 0.0 .and.  uref <= 6.5 ) then
      znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3)
    elseif (uref > 6.5 .and. uref <= 15.7) then
      znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 15.7 .and. uref <= 53.0) then
      znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 )
    elseif ( uref > 53.0) then
      znotm = p40
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_m_v7

  SUBROUTINE znot_t_v7(uref,znott)
  IMPLICIT NONE
! Calculate scalar roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF
! To be compatible with the slightly decreased Cd for higher wind speed
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znott(meter):   scalar roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znott

    REAL             :: p00
    REAL             :: p15, p14, p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p45, p44, p43, p42, p41, p40
    REAL             :: p56, p55, p54, p53, p52, p51, p50
    REAL             :: p60

    p00 =  1.100000000000000e-04

    p15 = -9.193764479895316e-10
    p14 =  7.052217518653943e-08
    p13 = -2.163419217747114e-06
    p12 =  3.342963077911962e-05
    p11 = -2.633566691328004e-04
    p10 =  8.644979973037803e-04

    p25 = -9.402722450219142e-12
    p24 =  1.325396583616614e-09
    p23 = -7.299148051141852e-08
    p22 =  1.982901461144764e-06
    p21 = -2.680293455916390e-05
    p20 =  1.484341646128200e-04

    p35 =  7.921446674311864e-12
    p34 = -1.019028029546602e-09
    p33 =  5.251986927351103e-08
    p32 = -1.337841892062716e-06
    p31 =  1.659454106237737e-05
    p30 = -7.558911792344770e-05

    p45 = -2.694370426850801e-10
    p44 =  5.817362913967911e-08
    p43 = -5.000813324746342e-06
    p42 =  2.143803523428029e-04
    p41 = -4.588070983722060e-03
    p40 =  3.924356617245624e-02

    p56 = -1.663918773476178e-13
    p55 =  6.724854483077447e-11
    p54 = -1.127030176632823e-08
    p53 =  1.003683177025925e-06
    p52 = -5.012618091180904e-05
    p51 =  1.329762020689302e-03
    p50 = -1.450062148367566e-02

    p60 =  6.840803042788488e-05

    if (uref >= 0.0 .and. uref < 5.9 ) then
      znott = p00
    elseif (uref >= 5.9 .and. uref <= 15.4) then
      znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10
    elseif (uref > 15.4 .and. uref <= 21.6) then
      znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 21.6 .and. uref <= 42.6) then
      znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30
    elseif ( uref > 42.6 .and. uref <= 53.0) then
      znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40
    elseif ( uref > 53.0 .and. uref <= 80.0) then
      znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50
    elseif ( uref > 80.0) then
      znott = p60
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_t_v7

  SUBROUTINE znot_m_v8(uref,znotm)
  IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
! For high winds, try to fit available observational data
! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed
! And this is another variation similar to v7
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znotm(meter):   areodynamical roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znotm
    REAL             :: p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p40

    p13 = -1.296521881682694e-02
    p12 =  2.855780863283819e-01
    p11 = -1.597898515251717e+00
    p10 = -8.396975715683501e+00

    p25 =  3.790846746036765e-10
    p24 =  3.281964357650687e-09
    p23 =  1.962282433562894e-07
    p22 = -1.240239171056262e-06
    p21 =  1.739759082358234e-07
    p20 =  2.147264020369413e-05

    p35 =  1.897534489606422e-07
    p34 = -3.019495980684978e-05
    p33 =  1.931392924987349e-03
    p32 = -6.797293095862357e-02
    p31 =  1.346757797103756e+00
    p30 = -1.707846930193362e+01

    p40 =  3.886804744928044e-04

    if (uref >= 0.0 .and.  uref <= 6.5 ) then
      znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3)
    elseif (uref > 6.5 .and. uref <= 15.7) then
      znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 15.7 .and. uref <= 51.5) then
      znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 )
    elseif ( uref > 51.5) then
      znotm = p40
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_m_v8

  SUBROUTINE znot_t_v8(uref,znott)
  IMPLICIT NONE
! Calculate scalar roughness over water with input 10-m wind
! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF
! To be compatible with the slightly decreased Cd for higher wind speed
! And this is another variation similar to v7
!
! Bin Liu, NOAA/NCEP/EMC 2018
!
! uref(m/s)   :   wind speed at 10-m height
! znott(meter):   scalar roughness scale over water
!

    REAL, INTENT(IN) :: uref
    REAL, INTENT(OUT):: znott

    REAL             :: p00
    REAL             :: p15, p14, p13, p12, p11, p10
    REAL             :: p25, p24, p23, p22, p21, p20
    REAL             :: p35, p34, p33, p32, p31, p30
    REAL             :: p45, p44, p43, p42, p41, p40
    REAL             :: p56, p55, p54, p53, p52, p51, p50
    REAL             :: p60

    p00 =  1.100000000000000e-04

    p15 = -9.193764479895316e-10
    p14 =  7.052217518653943e-08
    p13 = -2.163419217747114e-06
    p12 =  3.342963077911962e-05
    p11 = -2.633566691328004e-04
    p10 =  8.644979973037803e-04

    p25 = -9.402722450219142e-12
    p24 =  1.325396583616614e-09
    p23 = -7.299148051141852e-08
    p22 =  1.982901461144764e-06
    p21 = -2.680293455916390e-05
    p20 =  1.484341646128200e-04

    p35 =  7.921446674311864e-12
    p34 = -1.019028029546602e-09
    p33 =  5.251986927351103e-08
    p32 = -1.337841892062716e-06
    p31 =  1.659454106237737e-05
    p30 = -7.558911792344770e-05

    p45 = -2.706461188613193e-10
    p44 =  5.845859022891930e-08
    p43 = -5.027577045502003e-06
    p42 =  2.156326523752734e-04
    p41 = -4.617267288861201e-03
    p40 =  3.951492707214883e-02

    p56 = -1.112896580069263e-13
    p55 =  4.450334755105140e-11
    p54 = -7.375373918500171e-09
    p53 =  6.493685149526543e-07
    p52 = -3.206421106713471e-05
    p51 =  8.407596231678149e-04
    p50 = -9.027924333673693e-03

    p60 =  5.791179079892191e-05

    if (uref >= 0.0 .and. uref < 5.9 ) then
      znott = p00
    elseif (uref >= 5.9 .and. uref <= 15.4) then
      znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10
    elseif (uref > 15.4 .and. uref <= 21.6) then
      znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20
    elseif (uref > 21.6 .and. uref <= 42.6) then
      znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30
    elseif ( uref > 42.6 .and. uref <= 51.5) then
      znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40
    elseif ( uref > 51.5 .and. uref <= 80.0) then
      znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50
    elseif ( uref > 80.0) then
      znott = p60
    else
      print*, 'Wrong input uref value:',uref
    endif

  END SUBROUTINE znot_t_v8

   SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf)
   IMPLICIT NONE

! w10m(m/s)   :   10-m wind speed
! znott(meter):   Roughness scale for temperature/moisture, zt
! znotm(meter):   Roughness scale for momentum, z0
! Author      :  Weiguo Wang on 02/24/2016
!            convert from icoef=0,1,2 to have 10m level cd, ch match obs
     REAL, INTENT(IN) :: w10m
     INTEGER, INTENT(IN) :: icoef_sf
     REAL, INTENT(OUT):: znott, znotm

     real :: zm,zt,windmks, zlev,z10, tmp, zlevt, aaa, zm1,zt1
        zlev=20.0
        zlevt=10.0
        z10=10.0
            windmks=w10m
            if (windmks > 85.0) windmks=85.0
            if (windmks < 1.0) windmks=1.0
            if ( icoef_sf .EQ. 1) then
              call  znot_m_v1(windmks,zm1)
              call  znot_t_v1(windmks,zt1)

            else if ( icoef_sf .EQ. 0 ) then
              call  znot_m_v0(windmks,zm1)
              call  znot_t_v0(windmks,zt1)

            else  if( icoef_sf .EQ. 2 ) then
              call  znot_m_v1(windmks,zm1)
              call  znot_t_v2(windmks,zt1)

            else  if( icoef_sf .EQ. 3 ) then
              call  znot_m_v1(windmks,zm)
              call  znot_t_v2(windmks,zt)
!! adjust a little to match obs at 10m, cd is reduced
            tmp=0.4*0.4/(alog(zlev/zm))**2   ! cd at zlev
            zm1=z10/exp( sqrt(0.4*0.4/(tmp*0.95-0.0002)) )
!ch
            tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
            zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) )  )

            else if( icoef_sf .EQ. 4 ) then

              call  znot_m_v1(windmks,zm)
              call  znot_t_v2(windmks,zt)
!!  for wind<20, cd similar to icoef=2 at 10m, then reduced
             tmp=0.4*0.4/(alog(10.0/zm))**2   ! cd at zlev
             aaa=0.75
            if (windmks < 20) then
              aaa=0.99
            elseif(windmks < 45.0) then
              aaa=0.99+(windmks-20)*(0.75-0.99)/(45.0-20.0)
            endif
            zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) )
!ch
          tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
            zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) )  )

            else if( icoef_sf .EQ. 5 ) then

              call  znot_m_v1(windmks,zm)
              call  znot_t_v2(windmks,zt)
!!  for wind<20, cd similar to icoef=2 at 10m, then reduced
             tmp=0.4*0.4/(alog(10.0/zm))**2   ! cd at zlev
             aaa=0.80
            if (windmks < 20) then
              aaa=1.0
            elseif(windmks < 45.0) then
              aaa=1.0+(windmks-20)*(0.80-1.0)/(45.0-20.0)
            endif
            zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) )
!ch
          tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
            zt1=z10/exp( 0.4*0.4/( 1.0*tmp*alog(z10/zm1) )  )

            else  if( icoef_sf .EQ. 6 ) then
              call  znot_m_v6(windmks,zm1)
              call  znot_t_v6(windmks,zt1)
            else  if( icoef_sf .EQ. 7 ) then
              call  znot_m_v7(windmks,zm1)
              call  znot_t_v7(windmks,zt1)
            else  if( icoef_sf .EQ. 8 ) then
              call  znot_m_v8(windmks,zm1)
              call  znot_t_v8(windmks,zt1)
           else
             write(0,*)'stop, icoef_sf must be one of 0,1,2,3,4,5,6,7,8'
             stop
          endif
          znott=zt1
          znotm=zm1

  end subroutine znot_wind10m

END MODULE module_sf_exchcoef


      subroutine resid_eqrpib2(ctfm,ctfmp,n_a1,n_alpha,n_b1,n_beta,n_rPI
     &b2,n_rpsi,np1_a1,np1_alpha,np1_b1,np1_beta,np1_rPIb2,np1_rpsi,octf
     &mp,x,Nx,ht,hx,mass,myzero,zepsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 mass
      real*8 myzero
      real*8 zepsdis
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPIb2(Nx)
      real*8 n_rpsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_b1(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_rPIb2(Nx)
      real*8 np1_rpsi(Nx)
      real*8 octfmp(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_rPIb2(i) - 0.1333333333333333D1 * np1_rPIb2(i + 1) + 0.33
     #33333333333333D0 * np1_rPIb2(i + 2)
      res = res + qb**2
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = (-0.1D1 * n_rPIb2(i) + np1_rPIb2(i)) / ht + 0.500000000000000
     #0D0 * np1_a1(i) * mass * np1_rpsi(i) * np1_alpha(i) * np1_b1(i) **
     # 2 - 0.1D1 * np1_rPIb2(i) * np1_beta(i) / ctfm(i) - 0.500000000000
     #0000D0 * ((0.5000000000000000D0 * np1_rPIb2(i) * (-0.1D1 * np1_bet
     #a(i - 1) + np1_beta(i + 1)) + 0.5000000000000000D0 * np1_beta(i) *
     # (-0.1D1 * np1_rPIb2(i - 1) + np1_rPIb2(i + 1)) - 0.50000000000000
     #00D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) *
     #octfmp(i) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) + 0.1D1 / np
     #1_a1(i) * np1_alpha(i) * np1_b1(i) ** 2 * (-0.1D1 * np1_rpsi(i - 1
     #) + np1_rpsi(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.50000000000000
     #00D0 * (-0.2500000000000000D0 / np1_a1(i) ** 2 * (-0.1D1 * np1_rps
     #i(i - 1) + np1_rpsi(i + 1)) * (-0.1D1 * np1_a1(i - 1) + np1_a1(i +
     # 1)) * np1_alpha(i) * np1_b1(i) ** 2 - 0.2500000000000000D0 / np1_
     #a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) * (np1_alpha(
     #i - 1) - 0.1D1 * np1_alpha(i + 1)) * np1_b1(i) ** 2 + 0.5000000000
     #000000D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)
     #) * (-0.1D1 * np1_b1(i - 1) + np1_b1(i + 1)) * np1_alpha(i) * np1_
     #b1(i) + 0.1D1 / np1_a1(i) * (np1_rpsi(i - 1) - 0.2D1 * np1_rpsi(i)
     # + np1_rpsi(i + 1)) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) **
     # 2 / hx ** 2 + 0.5000000000000000D0 * n_a1(i) * mass * n_rpsi(i) *
     # n_alpha(i) * n_b1(i) ** 2 - 0.1D1 * n_rPIb2(i) * n_beta(i) / ctfm
     #(i) - 0.5000000000000000D0 * ((0.5000000000000000D0 * n_rPIb2(i) *
     # (-0.1D1 * n_beta(i - 1) + n_beta(i + 1)) + 0.5000000000000000D0 *
     # n_beta(i) * (-0.1D1 * n_rPIb2(i - 1) + n_rPIb2(i + 1)) - 0.500000
     #0000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1))
     #* octfmp(i) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) + 0.1D1 / n_a1
     #(i) * n_alpha(i) * n_b1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rpsi
     #(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.5000000000000000D0 * (-0.2
     #500000000000000D0 / n_a1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rps
     #i(i + 1)) * (-0.1D1 * n_a1(i - 1) + n_a1(i + 1)) * n_alpha(i) * n_
     #b1(i) ** 2 - 0.2500000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i -
     # 1) + n_rpsi(i + 1)) * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) *
     # n_b1(i) ** 2 + 0.5000000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(
     #i - 1) + n_rpsi(i + 1)) * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) * n
     #_alpha(i) * n_b1(i) + 0.1D1 / n_a1(i) * (n_rpsi(i - 1) - 0.2D1 * n
     #_rpsi(i) + n_rpsi(i + 1)) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i)
     #** 2 / hx ** 2 + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * n
     #p1_rPIb2(i) + np1_rPIb2(i + 2) - 0.4D1 * np1_rPIb2(i + 1) - 0.4D1
     #* np1_rPIb2(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D
     #1 * n_rPIb2(i) + n_rPIb2(i + 2) - 0.4D1 * n_rPIb2(i + 1) - 0.4D1 *
     # n_rPIb2(i - 1))
      res = res + qb**2
      end do
      endif
      do i=3, Nx-2, 1
      qb = (-0.1D1 * n_rPIb2(i) + np1_rPIb2(i)) / ht + 0.500000000000000
     #0D0 * np1_a1(i) * mass * np1_rpsi(i) * np1_alpha(i) * np1_b1(i) **
     # 2 - 0.1D1 * np1_rPIb2(i) * np1_beta(i) / ctfm(i) - 0.500000000000
     #0000D0 * ((0.5000000000000000D0 * np1_rPIb2(i) * (-0.1D1 * np1_bet
     #a(i - 1) + np1_beta(i + 1)) + 0.5000000000000000D0 * np1_beta(i) *
     # (-0.1D1 * np1_rPIb2(i - 1) + np1_rPIb2(i + 1)) - 0.50000000000000
     #00D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) *
     #octfmp(i) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) + 0.1D1 / np
     #1_a1(i) * np1_alpha(i) * np1_b1(i) ** 2 * (-0.1D1 * np1_rpsi(i - 1
     #) + np1_rpsi(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.50000000000000
     #00D0 * (-0.2500000000000000D0 / np1_a1(i) ** 2 * (-0.1D1 * np1_rps
     #i(i - 1) + np1_rpsi(i + 1)) * (-0.1D1 * np1_a1(i - 1) + np1_a1(i +
     # 1)) * np1_alpha(i) * np1_b1(i) ** 2 - 0.2500000000000000D0 / np1_
     #a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) * (np1_alpha(
     #i - 1) - 0.1D1 * np1_alpha(i + 1)) * np1_b1(i) ** 2 + 0.5000000000
     #000000D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)
     #) * (-0.1D1 * np1_b1(i - 1) + np1_b1(i + 1)) * np1_alpha(i) * np1_
     #b1(i) + 0.1D1 / np1_a1(i) * (np1_rpsi(i - 1) - 0.2D1 * np1_rpsi(i)
     # + np1_rpsi(i + 1)) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) **
     # 2 / hx ** 2 + 0.5000000000000000D0 * n_a1(i) * mass * n_rpsi(i) *
     # n_alpha(i) * n_b1(i) ** 2 - 0.1D1 * n_rPIb2(i) * n_beta(i) / ctfm
     #(i) - 0.5000000000000000D0 * ((0.5000000000000000D0 * n_rPIb2(i) *
     # (-0.1D1 * n_beta(i - 1) + n_beta(i + 1)) + 0.5000000000000000D0 *
     # n_beta(i) * (-0.1D1 * n_rPIb2(i - 1) + n_rPIb2(i + 1)) - 0.500000
     #0000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1))
     #* octfmp(i) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) + 0.1D1 / n_a1
     #(i) * n_alpha(i) * n_b1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rpsi
     #(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.5000000000000000D0 * (-0.2
     #500000000000000D0 / n_a1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rps
     #i(i + 1)) * (-0.1D1 * n_a1(i - 1) + n_a1(i + 1)) * n_alpha(i) * n_
     #b1(i) ** 2 - 0.2500000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i -
     # 1) + n_rpsi(i + 1)) * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) *
     # n_b1(i) ** 2 + 0.5000000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(
     #i - 1) + n_rpsi(i + 1)) * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) * n
     #_alpha(i) * n_b1(i) + 0.1D1 / n_a1(i) * (n_rpsi(i - 1) - 0.2D1 * n
     #_rpsi(i) + n_rpsi(i + 1)) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i)
     #** 2 / hx ** 2 + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * n
     #p1_rPIb2(i) + np1_rPIb2(i + 2) + np1_rPIb2(i - 2) - 0.4D1 * np1_rP
     #Ib2(i + 1) - 0.4D1 * np1_rPIb2(i - 1)) + 0.3125000000000000D-1 * z
     #epsdis / ht * (0.6D1 * n_rPIb2(i) + n_rPIb2(i + 2) + n_rPIb2(i - 2
     #) - 0.4D1 * n_rPIb2(i + 1) - 0.4D1 * n_rPIb2(i - 1))
      res = res + qb**2
      end do
      do i=Nx-1, Nx-1, 1
      qb = (-0.1D1 * n_rPIb2(i) + np1_rPIb2(i)) / ht + 0.500000000000000
     #0D0 * np1_a1(i) * mass * np1_rpsi(i) * np1_alpha(i) * np1_b1(i) **
     # 2 - 0.1D1 * np1_rPIb2(i) * np1_beta(i) / ctfm(i) - 0.500000000000
     #0000D0 * ((0.5000000000000000D0 * np1_rPIb2(i) * (-0.1D1 * np1_bet
     #a(i - 1) + np1_beta(i + 1)) + 0.5000000000000000D0 * np1_beta(i) *
     # (-0.1D1 * np1_rPIb2(i - 1) + np1_rPIb2(i + 1)) - 0.50000000000000
     #00D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) *
     #octfmp(i) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) + 0.1D1 / np
     #1_a1(i) * np1_alpha(i) * np1_b1(i) ** 2 * (-0.1D1 * np1_rpsi(i - 1
     #) + np1_rpsi(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.50000000000000
     #00D0 * (-0.2500000000000000D0 / np1_a1(i) ** 2 * (-0.1D1 * np1_rps
     #i(i - 1) + np1_rpsi(i + 1)) * (-0.1D1 * np1_a1(i - 1) + np1_a1(i +
     # 1)) * np1_alpha(i) * np1_b1(i) ** 2 - 0.2500000000000000D0 / np1_
     #a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)) * (np1_alpha(
     #i - 1) - 0.1D1 * np1_alpha(i + 1)) * np1_b1(i) ** 2 + 0.5000000000
     #000000D0 / np1_a1(i) * (-0.1D1 * np1_rpsi(i - 1) + np1_rpsi(i + 1)
     #) * (-0.1D1 * np1_b1(i - 1) + np1_b1(i + 1)) * np1_alpha(i) * np1_
     #b1(i) + 0.1D1 / np1_a1(i) * (np1_rpsi(i - 1) - 0.2D1 * np1_rpsi(i)
     # + np1_rpsi(i + 1)) * np1_alpha(i) * np1_b1(i) ** 2) / ctfmp(i) **
     # 2 / hx ** 2 + 0.5000000000000000D0 * n_a1(i) * mass * n_rpsi(i) *
     # n_alpha(i) * n_b1(i) ** 2 - 0.1D1 * n_rPIb2(i) * n_beta(i) / ctfm
     #(i) - 0.5000000000000000D0 * ((0.5000000000000000D0 * n_rPIb2(i) *
     # (-0.1D1 * n_beta(i - 1) + n_beta(i + 1)) + 0.5000000000000000D0 *
     # n_beta(i) * (-0.1D1 * n_rPIb2(i - 1) + n_rPIb2(i + 1)) - 0.500000
     #0000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1))
     #* octfmp(i) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) + 0.1D1 / n_a1
     #(i) * n_alpha(i) * n_b1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rpsi
     #(i + 1)) / ctfmp(i) / ctfm(i)) / hx - 0.5000000000000000D0 * (-0.2
     #500000000000000D0 / n_a1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rps
     #i(i + 1)) * (-0.1D1 * n_a1(i - 1) + n_a1(i + 1)) * n_alpha(i) * n_
     #b1(i) ** 2 - 0.2500000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i -
     # 1) + n_rpsi(i + 1)) * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) *
     # n_b1(i) ** 2 + 0.5000000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(
     #i - 1) + n_rpsi(i + 1)) * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) * n
     #_alpha(i) * n_b1(i) + 0.1D1 / n_a1(i) * (n_rpsi(i - 1) - 0.2D1 * n
     #_rpsi(i) + n_rpsi(i + 1)) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i)
     #** 2 / hx ** 2
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = (-0.1D1 * n_rPIb2(i) + np1_rPIb2(i)) / ht - 0.1D1 * myzero *
     #x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


      SUBROUTINE slCLYD (IY, IM, ID, NY, ND, JSTAT)
*+
*     - - - - -
*      C L Y D
*     - - - - -
*
*  Gregorian calendar to year and day in year (in a Julian calendar
*  aligned to the 20th/21st century Gregorian calendar).
*
*  Given:
*     IY,IM,ID   i    year, month, day in Gregorian calendar
*
*  Returned:
*     NY         i    year (re-aligned Julian calendar)
*     ND         i    day in year (1 = January 1st)
*     JSTAT      i    status:
*                       0 = OK
*                       1 = bad year (before -4711)
*                       2 = bad month
*                       3 = bad day (but conversion performed)
*
*  Notes:
*
*  1  This routine exists to support the low-precision routines
*     slERTH, slMOON and slECOR.
*
*  2  Between 1900 March 1 and 2100 February 28 it returns answers
*     which are consistent with the ordinary Gregorian calendar.
*     Outside this range there will be a discrepancy which increases
*     by one day for every non-leap century year.
*
*  3  The essence of the algorithm is first to express the Gregorian
*     date as a Julian Day Number and then to convert this back to
*     a Julian calendar date, with day-in-year instead of month and
*     day.  See 12.92-1 and 12.95-1 in the reference.
*
*  Reference:  Explanatory Supplement to the Astronomical Almanac,
*              ed P.K.Seidelmann, University Science Books (1992),
*              p604-606.
*
*  P.T.Wallace   Starlink   26 November 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IY,IM,ID,NY,ND,JSTAT

      INTEGER I,J,K,L,N

*  Month lengths in days
      INTEGER MTAB(12)
      DATA MTAB/31,28,31,30,31,30,31,31,30,31,30,31/

*  Preset status
      JSTAT=0

*  Validate year
      IF (IY.GE.-4711) THEN

*     Validate month
         IF (IM.GE.1.AND.IM.LE.12) THEN

*        Allow for (Gregorian) leap year
            IF (MOD(IY,4).EQ.0.AND.
     :         (MOD(IY,100).NE.0.OR.MOD(IY,400).EQ.0)) THEN
               MTAB(2)=29
            ELSE
               MTAB(2)=28
            END IF

*        Validate day
            IF (ID.LT.1.OR.ID.GT.MTAB(IM)) JSTAT=3

*        Perform the conversion
            I=(14-IM)/12
            K=IY-I
            J=(1461*(K+4800))/4+(367*(IM-2+12*I))/12
     :        -(3*((K+4900)/100))/4+ID-30660
            K=(J-1)/1461
            L=J-1461*K
            N=(L-1)/365-L/1461
            J=((80*(L-365*N+30))/2447)/11
            I=N+J
            ND=59+L-365*I+((4-N)/4)*(1-J)
            NY=4*K+I-4716

*        Bad month
         ELSE
            JSTAT=2
         END IF
      ELSE

*     Bad year
         JSTAT=1
      END IF

      END


program main
    use fem
    implicit none

    type(FEMDomain_) :: domain
    type(ShapeFunction_) :: shapefn
    integer(int32) :: i

    call domain%create(meshtype="Cube")
    do i=1,size(domain%mesh%ElemNod,1)
        shapefn = domain%getShapeFunction(ElementID=i,GaussPointID=1)
        print *, real(shapefn%ElemCoord(1,:))
    enddo

end program main


!> subroutine for the calculation of rates in the Redfield approximation
SUBROUTINE calculate_redfield_rates_mpi
    USE harmonic_bath
    USE hamiltonians
    USE input_output
    USE kinds
    USE linear_algebra
    USE parameters
    USE fourier
    USE unit_conversions
    IMPLICIT NONE
    INTEGER :: i,j,k
    REAL(dp) :: eigenvectors(nstate,nstate), exciton_energies(nstate)
    REAL(dp) :: exciton_reorg(nstate)
    REAL(dp) :: site_bath_cf(nstate, 0:nbstep)
    REAL(dp) :: exciton_bath_cf(nstate, nstate, 0:nbstep)
    REAL(dp) :: ft_exciton_bath_cf(nstate,nstate)
    REAL(dp) :: beta, dt, dw_electronic, freq
    exciton_energies = 0.0_dp ; eigenvectors = 0.0_dp
    exciton_reorg = 0.0_dp ; dw_electronic = 0.0_dp
    site_bath_cf = 0.0_dp ; ft_exciton_bath_cf = 0.0_dp
    exciton_bath_cf = 0.0_dp ; freq = 0.0_dp

    beta = 1.0_dp / ( temperature * convert('kelvin','au_energy') )
    runtime = runtime * convert('fs','au_time')
    dt = runtime / DBLE(nbstep)

    !> Read in the system Hamiltonian
    CALL read_hel
    hel = hel * convert('wvnbr','au_energy')

    !> Diagonalize to get Eigenvectors and Energy Eigenvalues
    eigenvectors = hel
    CALL diagonalize_real_symmetric(eigenvectors, exciton_energies)

    !> Calculate the exciton basis reorganization energy
    DO i = 1, nstate
        DO j = 1, nstate
            exciton_reorg(i) = exciton_reorg(i) + &
                    site_reorg(j) * eigenvectors(j,i) ** 4
        END DO
    END DO

!    !> Calculate size of electronic bath frequency grid
!    dw_electronic = electronic_bath_freq(2) - electronic_bath_freq(1)

    !> Calculate the bath correlation functions for the modes coupled to sites
    DO i = 1, nstate
        site_bath_cf(i,:) = redfield_bath_correlation_function(site_sd(i,:), &
                site_bath_freq,beta)
    END DO

    !> Linearly combine the site bath correlation functions to get the exciton ones
    DO i=1,nstate
        DO j=1,nstate
            DO k=1,nstate
                exciton_bath_cf(i,j,:) = exciton_bath_cf(i,j,:) &
                        + eigenvectors(k,i)**2 * site_bath_cf(k,:) * eigenvectors(k,j)**2
            END DO
        END DO
    END DO

    !> Fourier Transform the bath correlation function in exciton basis
    DO i=1, nstate
        DO j=1, nstate
                freq = exciton_energies(i) - exciton_energies(j)
                ft_exciton_bath_cf(i,j) = ft_at_omega( exciton_bath_cf(i,j,:), freq, dt )
        END DO
    END DO

END SUBROUTINE calculate_redfield_rates_mpi