module module_math

  use, intrinsic :: IEEE_ARITHMETIC, ONLY : IEEE_VALUE, IEEE_QUIET_NAN
  use module_types, only: dp
  use module_constants
  use module_utils

  implicit none

  integer, parameter                  :: NPAR_ARTH  = 16
  integer, parameter                  :: NPAR2_ARTH = 8

  type type_point
    real(dp)                          :: x = 0.d0
    real(dp)                          :: y = 0.d0
    real(dp)                          :: z = 0.d0
  end type type_point

  interface interp1d
    module procedure interp1ds,interp1dv
  end interface interp1d

  interface swap
    module procedure swap_i,swap_d,swap_dv,swap_c,swap_cv
  end interface swap

contains
! ...
! =====================================================================
! ...
subroutine swap_i(a,b)  ! Integer swap
  integer, intent(inout)        :: a,b
  integer dum
  dum = a; a = b; b = dum
end subroutine swap_i
! ...
! =====================================================================
! ...
subroutine swap_d(a,b)  ! Double precision swap
  real(dp), intent(inout)        :: a,b
  real(dp) dum
  dum = a; a = b; b = dum
end subroutine swap_d
! ...
! =====================================================================
! ...
subroutine swap_dv(a,b)  ! Double precision vector swap
  real(dp), dimension(:), intent(inout)        :: a,b
  real(dp) dum(size(a))
  dum = a; a = b; b = dum
end subroutine swap_dv
! ...
! =====================================================================
! ...
subroutine swap_c(a,b)  ! Complex swap
  complex(dp), intent(inout)        :: a,b
  complex(dp) dum
  dum = a; a = b; b = dum
end subroutine swap_c
! ...
! =====================================================================
! ...
subroutine swap_cv(a,b) ! Complex vector swap
  complex(dp), dimension(:), intent(inout)        :: a,b
  complex(dp) dum(size(a))
  dum = a; a = b; b = dum
end subroutine swap_cv
! ...
! =====================================================================
! ...
function outerprod(a,b)
  real(dp), dimension(:), intent(in)              :: a,b
  real(dp), dimension(size(a),size(b))            :: outerprod
  outerprod = spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))
end function outerprod
! ...
! =====================================================================
! ...
real(dp) function vabs(v) ! Returns the length (ordinary L2 norm) of a vector.
  real(dp), dimension(:), intent(in)  :: v
  vabs = sqrt(dot_product(v,v))
end function vabs
! ...
! =====================================================================
! ...
real(dp) function haversine (lon1,lat1,lon2,lat2)
  ! ...
  ! ... Function Haversine
  ! ... Determines the great-circle distance between two points in a
  ! ... sphere. The input lngitudes and latitudes are given in radians
  ! ... The retruned distance is in meters.
  ! ... Rearth = 6371315.0_dp      ! m
  ! ...
  real(dp), intent(in)                  :: lon1,lat1
  real(dp), intent(in)                  :: lon2,lat2

  ! ... Local variables
  ! ...
  real(dp) sindx,sindy,dang

  sindx = sin(0.5D0*(lon2-lon1))
  sindy = sin(0.5D0*(lat2-lat1))

  dang = 2.0d0*asin(sqrt(sindy*sindy + cos(lat2)*cos(lat1)*sindx*sindx))
  haversine = Rearth * dang

  return
end function haversine
! ...
! =====================================================================
! ...
! ... Subroutine indexx from Numerical Recipes in Fortran.
! ... The Art of Scientific Computing. Press et al., 1992.
! ...
      subroutine indexx(arr,indx)

      real(dp), dimension(:), intent(in)          :: arr
      integer, dimension(size(arr)), intent(out)  :: indx

      ! ... Local varibles:
      ! ...
      integer, parameter                          :: M=7
      integer                                     :: n,i,indxt,ir,itemp,j,jstack,k,l
      integer, dimension(size(arr))               :: istack
      real(dp)                                    :: a

      n = size(arr)

      do j=1,n
        indx(j)=j
      enddo

      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do j=l+1,ir
          indxt=indx(j)
          a=arr(indxt)
          do i=j-1,1,-1
            if(arr(indx(i)).le.a) goto 2
            indx(i+1)=indx(i)
          enddo
          i=0
2         indx(i+1)=indxt
        enddo
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        itemp=indx(k)
        indx(k)=indx(l+1)
        indx(l+1)=itemp
        if(arr(indx(l+1)).gt.arr(indx(ir)))then
          itemp=indx(l+1)
          indx(l+1)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l)).gt.arr(indx(ir)))then
          itemp=indx(l)
          indx(l)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l+1)).gt.arr(indx(l)))then
          itemp=indx(l+1)
          indx(l+1)=indx(l)
          indx(l)=itemp
        endif
        i=l+1
        j=ir
        indxt=indx(l)
        a=arr(indxt)
3       continue
          i=i+1
        if(arr(indx(i)).lt.a)goto 3
4       continue
          j=j-1
        if(arr(indx(j)).gt.a)goto 4
        if(j.lt.i)goto 5
        itemp=indx(i)
        indx(i)=indx(j)
        indx(j)=itemp
        goto 3
5       indx(l)=indx(j)
        indx(j)=indxt
        jstack=jstack+2
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      end subroutine indexx
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =====================================================================
! ...
! ...
! ... Subroutine indexx from Numerical Recipes in Fortran.
! ... The Art of Scientific Computing. Press et al., 1992.
! ...
      subroutine indexi(arr,indx)

      integer, dimension(:), intent(in)          :: arr
      integer, dimension(size(arr)), intent(out)  :: indx

      ! ... Local varibles:
      ! ...
      integer, parameter                          :: M=7
      integer                                     :: n,i,indxt,ir,itemp,j,jstack,k,l
      integer, dimension(size(arr))               :: istack
      integer                                     :: a

      n = size(arr)

      do j=1,n
        indx(j)=j
      enddo

      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do j=l+1,ir
          indxt=indx(j)
          a=arr(indxt)
          do i=j-1,1,-1
            if(arr(indx(i)).le.a) goto 2
            indx(i+1)=indx(i)
          enddo
          i=0
2         indx(i+1)=indxt
        enddo
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        itemp=indx(k)
        indx(k)=indx(l+1)
        indx(l+1)=itemp
        if(arr(indx(l+1)).gt.arr(indx(ir)))then
          itemp=indx(l+1)
          indx(l+1)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l)).gt.arr(indx(ir)))then
          itemp=indx(l)
          indx(l)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l+1)).gt.arr(indx(l)))then
          itemp=indx(l+1)
          indx(l+1)=indx(l)
          indx(l)=itemp
        endif
        i=l+1
        j=ir
        indxt=indx(l)
        a=arr(indxt)
3       continue
          i=i+1
        if(arr(indx(i)).lt.a)goto 3
4       continue
          j=j-1
        if(arr(indx(j)).gt.a)goto 4
        if(j.lt.i)goto 5
        itemp=indx(i)
        indx(i)=indx(j)
        indx(j)=itemp
        goto 3
5       indx(l)=indx(j)
        indx(j)=indxt
        jstack=jstack+2
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      end subroutine indexi
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =====================================================================
! ...
function interp1ds(x,f,xx,method,bounds_error,fill_value) result(ff)

real(dp), dimension(:), intent(in)             :: x,f
real(dp), intent(in)                           :: xx
character(len=*), intent(in), optional         :: method
logical, intent(in), optional                  :: bounds_error
real(dp), intent(in), optional                 :: fill_value
real(dp)                                       :: ff

logical bounds
integer i
real(dp) nan,d1,d2,df(size(x))
character(1) lmethod

! ... Check valid data dimensions
! ...
if (size(x).ne.size(f)) call stop_error(1,'Error in interp1d: Incompatible sizes')
if (size(x).le.1) call stop_error(1,'Error in interp1d: N must be > 1')

! ... nan:
! ...
nan = ieee_value(1.0_dp,ieee_quiet_nan)

! ... Interpolation method: 'linar', 'nearest', 'spline'
! ...
lmethod = 'L'
if (present(method)) lmethod = method(1:1)

! ... Fill_value
! ...
ff = nan
if (present(fill_value)) ff = fill_value

! ... Boundaries
! ...
bounds = .True.
if (present(bounds_error)) bounds = bounds_error

if ((xx.lt.minval(x)).or.(xx.gt.maxval(x))) then
  if (bounds) call stop_error(1,'Error in interp1d: Value out of bounds')
  return
endif

! ... Linear interpolation
! ...
if ((lmethod.eq.'L'.or.lmethod.eq.'l')) then
  ! ... Linear interpolation
  ! ...
  i = locate(x,xx)
  if (i.eq.0) then
    ff = f(1)
  else
    ff = f(i) + (f(i+1)-f(i))*(xx-x(i))/(x(i+1)-x(i))
  endif
  return
else if ((lmethod.eq.'N'.or.lmethod.eq.'n')) then
  ! ... Nearest neighbor
  ! ...
  i = locate(x,xx)
  d1 = abs(x(i)-xx)
  d2 = abs(x(i+1)-xx)
  ff = f(i)
  if (d2.lt.d1) ff = f(i+1)
  return
else if ((lmethod.eq.'A'.or.lmethod.eq.'a')) then
  ! ... Akima splines
  ! ...
  df = dakima(x,f)
  ff = evlak(xx,x,f,df)
  return
else if ((lmethod.eq.'C'.or.lmethod.eq.'c')) then
  ! ... Cubic splines
  ! ...
  df = spline (x,f,2.0d30,2.0d30)
  ff = splint (x,f,df,xx)
  return
else
  call stop_error(1,'Error in interp1d: Method not valid')
endif

end function interp1ds
! ...
! =====================================================================
! ...
function interp1dv(x,f,xx,method,bounds_error,fill_value) result(ff)

real(dp), dimension(:), intent(in)             :: x,f
real(dp), dimension(:), intent(in)             :: xx
character(len=*), intent(in), optional         :: method
logical, intent(in), optional                  :: bounds_error
real(dp), intent(in), optional                 :: fill_value
real(dp), dimension(size(xx))                  :: ff

logical bounds
integer i,k,n
real(dp) nan,d1,d2,df(size(x))
real(dp) xmin,xmax
character(1) lmethod

n = size(xx)
if (n.eq.0) return

! ... Check valid data dimensions
! ...
if (size(x).ne.size(f)) call stop_error(1,'Error in interp1d: Incompatible sizes')
if (size(x).le.1) call stop_error(1,'Error in interp1d: N must be > 1')

! ... nan:
! ...
nan = ieee_value(1.0_dp,ieee_quiet_nan)

! ... Interpolation method: 'linar', 'nearest', 'spline'
! ...
lmethod = 'L'
if (present(method)) lmethod = method(1:1)

! ... Fill_value
! ...
ff(:) = nan
if (present(fill_value)) ff(:) = fill_value

! ... Boundaries
! ...
bounds = .True.
if (present(bounds_error)) bounds = bounds_error

xmin = minval(x)
xmax = maxval(x)
do i=1,n
  if ((xx(i).lt.xmin).or.(xx(i).gt.xmax)) then
    if (bounds) call stop_error(1,'Error in interp1d: Value out of bounds')
    return
  endif
enddo

if ((lmethod.eq.'L'.or.lmethod.eq.'l')) then
  ! ... Linear interpolation
  ! ...
  do k=1,n
    i = locate(x,xx(k))
    if (i.eq.0) then
      ff(k) = f(1)
    else
      ff(k) = f(i) + (f(i+1)-f(i))*(xx(k)-x(i))/(x(i+1)-x(i))
    endif
  enddo
  return
else if ((lmethod.eq.'N'.or.lmethod.eq.'n')) then
  ! ... Nearest point
  ! ...
  do k=1,n
    i = locate(x,xx(k))
    d1 = abs(x(i)-xx(k))
    d2 = abs(x(i+1)-xx(k))
    ff(k) = f(i)
    if (d2.lt.d1) ff(k) = f(i+1)
  enddo
  return
else if ((lmethod.eq.'A'.or.lmethod.eq.'a')) then
  ! ... Akima splines
  ! ...
  df = dakima(x,f)
  do k=1,n
    ff(k) = evlak(xx(k),x,f,df)
  enddo
  return
else if ((lmethod.eq.'C'.or.lmethod.eq.'c')) then
  ! ... Cubic splines
  ! ...
  df = spline (x,f,2.0d30,2.0d30)
  do k=1,n
    ff(k) = splint (x,f,df,xx(k))
  enddo
  return
else
  call stop_error(1,'Error in interp1d: Method not valid')
endif

end function interp1dv
! ...
! =====================================================================
! ...
function dakima (x,f) result(df)
! ... Given the array of samples of a function f and sample points x,
! ... assumed to be monotone, generates slopes for an interpolating rule
! ... according to Akima's algorithm (Lancaster and Salkauskas,
! ... Curve and surface fitting, 1986 academic press, p 82).

real(dp), dimension(:), intent(in)  :: x,f
real(dp), dimension(size(x))        :: df

! ... Local variables
! ...
integer                             :: i,n
real(dp)                            :: Sn,eps,D1,D2
real(dp), dimension(4)              :: S

n = size(x)
eps  = 1.0e-6*ABS(x(n) - x(1))

S(1) = (f(2) - f(1))/(x(2) - x(1))
S(2) = S(1)
S(3) = S(1)
S(4) = (f(3) - f(2))/(x(3) - x(2))
Sn   = (f(n) - f(n-1))/(x(n) - x(n-1))

do i=1, n
  D1 = abs(S(2) - S(1))
  D2 = abs(S(4) - S(3))
  df(i) = (D2*S(2) + D1*S(3))/(D1 + D2 + eps)

  S(1) = S(2)
  S(2) = S(3)
  S(3) = S(4)
  if (i+3.le.n) then
    S(4) = (f(i+3) - f(i+2))/(x(i+3)-x(i+2))
  else
    S(4) = Sn
  endif
enddo

if (n.eq.2) return

! ... If 3 or more points use gradient from a parabola for 1st & last df
! ...
df(1) = qakima(f(2)-f(1),x(2)-x(1),f(3)-f(1),x(3)-x(1))
df(n) = qakima(f(n-1)-f(n),x(n-1)-x(n),f(n-2)-f(n),x(n-2)-x(n))

contains

  ! -----------------------------------------
  real(dp) function qakima(u1,x1,u2,x2)
  ! -----------------------------------------
  real(dp), intent(in)       :: u1,x1,u2,x2
  qakima = (u1/x1**2-u2/x2**2)/(1.0_dp/x1-1.0_dp/x2)
  end function qakima

end function dakima
! ...
! =====================================================================
! ...
real(dp) function evlak(xc,x,f,df)
! ... Given a montone increasing array of x values (Note: routine does not
! ... check this), samples of values of the function f and 1st derivative
! ... df at the xs, interpolates by cubic polynomial.  The array df can be
! ... found by calling subroutine akima.
!
! ... If y falls outside the interval, the polynomial on the
! ... nearest interval is used to extrapolate.

real(dp), intent(in)                  :: xc
real(dp), dimension(:), intent(in)    :: x,f,df

! ... Local variables
! ...
integer k,n
integer init         ! Search for proper interval initiated at previous call
save init
data init/1/
real(dp) dx,t,s

n = size(x)

! ... Locate sample interval containing xc:  after xc lies in [x(init),
! ... x(init+1)), unless xc lies outside [x(1), x(n)] when the interval
! ... is the intervals containing the apprpriate end point.

init = min(init, n)
if (xc.gt.x(init)) then
  do k=init,n
    if (x(k).gt.xc) then
      init = k-1
      goto 1300
    endif
  enddo
  init = n-1
else
  do k=init,1,-1
    if (x(k).le.xc) then
      init = k
      goto 1300
    endif
  enddo
  init = 1
endif

1300 continue
dx = x(init+1) - x(init)

! ...  Evaluate the cubic interpolator
! ...
t = (xc - x(init))/dx
s = 1.0D0 - t
evlak = s**2*((1.0D0 + 2.0D0*t)*f(init)   + t*dx*df(init))   +     &
        t**2*((1.0D0 + 2.0D0*s)*f(init+1) - s*dx*df(init+1))
end function evlak
! ...
! =====================================================================
! ...
function spline(x,y,yp1,ypn) result(y2)

  real(dp), dimension(:), intent(in)    :: x,y
  real(dp), intent(in)                  :: yp1,ypn
  real(dp), dimension(size(x))          :: y2

  ! ... Local variables
  ! ...
  integer i,k,n
  real(dp) p,qn,sig,un,u(size(x))

  n = size(x)

  if (yp1.gt.0.99d30) then
    y2(1) = 0.d0
    u(1)  = 0.d0
  else
    y2(1) = -0.5d0
    u(1)  = (3.d0/(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.d0
    y2(i) = (sig-1.d0)/p
    u(i)  = (6.d0*((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
  enddo

  if (ypn.gt.0.99d30) then
    qn = 0.d0
    un = 0.d0
  else
    qn = 0.5d0
    un = (3.d0/(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.d0)
  do k=n-1,1,-1
    y2(k) = y2(k)*y2(k+1) + u(k)
  enddo

  return
! ...  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
end function spline
! ...
! =====================================================================
! ...
function splint(xa,ya,y2a,x) result(y)

  real(dp), dimension(:), intent(in)      :: xa,ya,y2a
  real(dp), intent(in)                    :: x
  real(dp)                                :: y

  integer n,k,khi,klo
  real(dp) a,b,h

  n = size(xa)

  klo = 1
  khi = n

  klo = max(min(locate(xa,x),n-1),1)
  khi = klo + 1

  h = xa(khi)-xa(klo)
  if (h.eq.0.d0) 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.d0

  return

!C  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
end function splint
! ...
! ====================================================================
! ...
subroutine mnbrak(ax,bx,cx,fa,fb,fc,func)

  real(dp), intent(inout)           :: ax,bx
  real(dp), intent(out)             :: cx,fa,fb,fc

  interface
    function func(x)
      use module_types, only: dp
      real(dp), intent(in)  :: x
      real(dp) func
    end function func
  end interface

  ! ... Local variables
  ! ...
  real(dp), parameter               :: GOLD=1.618034D0
  real(dp), parameter               :: GLIMIT=100.0D0
  real(dp), parameter               :: TINY=1.0D-20
  real(dp) fu,q,r,u,ulim

  fa = func(ax)
  fb = func(bx)
  if (fb > fa) then
    call swap(ax,bx)
    call swap(fa,fb)
  endif
  cx = bx + GOLD*(bx-ax)
  fc = func(cx)
  do
    if (fb < fc) return
    r = (bx-ax)*(fb-fc)
    q = (bx-cx)*(fb-fa)
    u = bx-0.5D0*((bx-cx)*q-(bx-ax)*r)/sign(max(abs(q-r),TINY),q-r)
    ulim = bx + GLIMIT*(cx-bx)
    if ((bx-u)*(u-cx) > 0.0D0) then
      fu = func(u)
      if (fu < fc) then
        ax = bx
        fa = fb
        bx = u
        fb = fu
        return
      else if (fu > fb) then
        cx = u
        fc = fu
        return
      endif
      u = cx + GOLD*(cx-bx)
      fu = func(u)
    else if ((cx-u)*(u-ulim) > 0.0D0) then
      fu = func(u)
      if (fu < fc) then
        bx = cx
        cx = u
        u  = cx + GOLD*(cx-bx)
        call shft(fb,fc,fu,func(u))
      endif
    else if ((u-ulim)*(ulim-cx) >= 0.0D0) then
      u  = ulim
      fu = func(u)
    else
      u  = cx + GOLD*(cx-bx)
      fu = func(u)
    endif
    call shft(ax,bx,cx,u)
    call shft(fa,fb,fc,fu)
  enddo

  contains
    subroutine shft(a,b,c,d)
      use module_types, only: dp
      real(dp), intent(out)   :: a
      real(dp), intent(inout) :: b,c
      real(dp), intent(in)    :: d
      a = b; b = c; c = d
    end subroutine shft

end subroutine mnbrak
! ...
! =====================================================================
! ...
real(dp) function brent(ax,bx,cx,func,tol,xmin)

  real(dp), intent(in)                 :: ax,bx,cx,tol
  real(dp), intent(out)                :: xmin
  interface
    function func(x)
      use module_types, only: dp
      real(dp), intent(in)    :: x
      real(dp)                :: func
    end function func
  end interface

  ! ... Local variables
  integer, parameter                   :: ITMAX=100
  real(dp), parameter                  :: CGOLD=0.3819660_dp,ZEPS=1.0D-3*epsilon(ax)
  integer iter
  real(dp) a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm

  a = min(ax,cx)
  b = max(ax,cx)
  v = bx
  w = v
  x = v
  e = 0.0D0
  fx =func(x)
  fv = fx
  fw = fx
  do iter=1,ITMAX
    xm = 0.5D0*(a+b)
    tol1 = tol*abs(x) + ZEPS
    tol2 = 2.0D0*tol1
    if (abs(x-xm) <= (tol2-0.5D0*(b-a))) then
      ! ... Exit with best values
      xmin = x
      brent = fx
      return
    endif
    if (abs(e) > tol1) then
      r = (x-w)*(fx-fv)
      q = (x-v)*(fx-fw)
      p = (x-v)*q - (x-w)*r
      q = 2.0D0*(q-r)
      if (q > 0.0D0) p = -p
      q = abs(q)
      etemp = e
      e = d
      if (abs(q) >= abs(0.5D0*q*etemp) .or. &
          p <= q*(a-x) .or. p >= q*(b-x)) then
        e = merge(a-x,b-x,x >= xm)
        d = CGOLD*e
      else
        d = p/q
        u = x + d
        if (u-a < tol2 .or. b-u < tol2) d = sign(tol1,xm-x)
      endif
    else
      e = merge(a-x,b-x, x>= xm)
      d = CGOLD*e
    endif
    u = merge(x+d,x+sign(tol1,d), abs(d) >= tol1 )
    fu = func(u)
    if (fu <= fx) then
      if ( u >= x) then
        a = x
      else
        b = x
      endif
      call shft(v,w,x,u)
      call shft(fv,fw,fx,fu)
    else
      if (u < x) then
        a = u
      else
        b = u
      endif
      if (fu <= fw .or. w == x) then
        v  = w
        fv = fw
        w  = u
        fw = fu
      else if (fu <= fv .or. v == x .or. v == w) then
        v  = u
        fv = fu
      endif
    endif
  enddo
  stop 'brent: exceed maximum iterations'
  contains
    subroutine shft(a,b,c,d)
      use module_types, only: dp
      real(dp), intent(out)   :: a
      real(dp), intent(inout) :: b,c
      real(dp), intent(in)    :: d
      a = b; b = c; c = d
    end subroutine shft
end function brent
! ...
! =====================================================================
! ...
subroutine lnsrch(xold,fold,g,p,x,f,stpmax,check,func)

  real(dp), dimension(:), intent(in)              :: xold,g
  real(dp), intent(in)                            :: fold,stpmax
  real(dp), dimension(:), intent(inout)           :: p
  real(dp), dimension(:), intent(out)             :: x
  real(dp), intent(out)                           :: f
  logical, intent(out)                            :: check

  interface
    function func(x)
      use module_types, only: dp
      implicit none
      real(dp), dimension(:), intent(in)   :: x
      real(dp) func
    end function func
  end interface

  ! ... Local variables
  ! ...
  real(dp), parameter                             ::  ALF = 1.0D-4
  real(dp), parameter                             :: TOLX = epsilon(x)
  integer ndum
  real(dp) a,alam,alam2,alamin,b,disc,f2,pabs,rhs1,rhs2,slope,tmplam

  ndum = size(g)
  if (any([size(p),size(x),size(xold)].ne.ndum)) &
             call stop_error(1,'lnsrch: incompatible dimensions')

  check = .False.
  pabs  = vabs(p(:))
  if (pabs > stpmax) p(:) = p(:)*stpmax/pabs ! Scaling data
  slope = dot_product(g,p)
  if (slope >= zero) call stop_error(1,'lnsrch: roundoff error')

  alamin = TOLX/maxval(abs(p(:))/max(abs(xold(:)),one)) ! Lambda min
  alam   = one
  do
    x(:) = xold(:) + alam*p(:)
    f    = func(x)
    if (alam < alamin) then
      x(:) = xold(:)
      check = .True.
      return
    else if ( f <= fold+ALF*alam*slope) then
      return    ! Sufficient function decrease
    else
      if (alam == one) then
        tmplam = -half*slope/(f-fold-slope)
      else
        rhs1 = f - fold - alam*slope
        rhs2 = f2 - fold - alam2*slope
           a = (rhs1/alam**2 - rhs2/alam2**2)/(alam-alam2)
           b = (-alam2*rhs1/alam**2 + alam*rhs2/alam2**2)/(alam-alam2)
        if (a == zero) then
          tmplam = -half*slope/b
        else
          disc = b*b - three*a*slope
          if (disc < zero) then
            tmplam = half*alam
          else if (b <= zero) then
            tmplam = (-b+sqrt(disc))/(three*a)
          else
            tmplam = -slope/(b+sqrt(disc))
          endif
        endif
        if (tmplam > half*alam) tmplam = 0.5*alam ! Lambda <= 0.5 Lambda_1
      endif
    endif
    alam2 = alam
       f2 = f
     alam = max(tmplam,0.1D0*alam)
  enddo

end subroutine lnsrch
! ...
! =====================================================================
! ...
subroutine dfpmin (p,gtol,iter,fret,func,dfunc)

  real(dp), dimension(:), intent(inout)           :: p
  real(dp), intent(in)                            :: gtol
  integer, intent(out)                            :: iter
  real(dp), intent(out)                           :: fret

  interface
    function func(p)
      use module_types, only: dp
      real(dp), dimension(:), intent(in) :: p
      real(dp) func
    end function func

    function dfunc(p)
      use module_types, only: dp
      real(dp), dimension(:), intent(in) :: p
      real(dp), dimension(size(p))       :: dfunc
    end function dfunc
  end interface

  ! ... Local variables
  ! ....
  integer, parameter                 :: ITMAX = 200
  real(dp), parameter                :: STPMX = 100.D0
  real(dp), parameter                ::   EPS = epsilon(p)
  real(dp), parameter                ::  TOLX = 4.0D0*EPS

  logical check
  integer its,i,n
  real(dp)  den,fac,fad,fae,fp,stpmax,sumdg,sumxi
  real(dp), dimension(size(p))          :: dg,g,hdg,pnew,xi
  real(dp), dimension(size(p),size(p))  :: hessin

   n = size(p)
  fp = func(p)
   g = dfunc(p)

  hessin(:,:) = zero
  do i=1,n
    hessin(i,i) = one
  enddo

  xi = -g
  stpmax = STPMX*max(vabs(p),real(n,dp))
  do its=1,ITMAX
    iter = its
    call lnsrch(p,fp,g,xi,pnew,fret,stpmax,check,func)
    fp = fret
    xi = pnew - p
    p  = pnew
    if (maxval(abs(xi)/max(abs(p),one)) < TOLX) return

    dg = g
     g = dfunc(p)
   den = max(fret,one)
   if (maxval(abs(g)*max(abs(p),one)/den) < gtol) return

       dg = g - dg
      hdg = matmul(hessin,dg)
      fac = dot_product(dg,xi)
      fae = dot_product(dg,hdg)
    sumdg = dot_product(dg,dg)
    sumxi = dot_product(xi,xi)
    if (fac > sqrt(EPS*sumdg*sumxi)) then
      fac = one/fac
      fad = one/fae
      dg = fac*xi - fad*hdg
      hessin = hessin + fac*outerprod(xi,xi)   - &
                        fad*outerprod(hdg,hdg) + &
                        fae*outerprod(dg,dg)
    endif
    xi = -matmul(hessin,g)
  enddo
  call stop_error(1,'dfpmin: too many iterations')

end subroutine dfpmin
! ...
! =====================================================================
! ...
real(dp) function mean(A,W)
! ... Calculates the weighted mean = 1/N * Sum W(i)*A(i)
! ... Weights are optional.

  real(dp), dimension(:), intent(in)     :: A
  real(dp), dimension(:), optional       :: W

  integer n
  real(dp) nan,Sw

  ! ... nan:
  ! ...
  nan = ieee_value(1.0_dp,ieee_quiet_nan)

  mean = nan
  n = size(A)
  if (n.eq.0) return

  if (present(W)) then
    Sw   = sum(W)
    mean = dot_product(W,A)/Sw
  else
    mean = sum(A)/N
  endif

end function mean
! ...
! =====================================================================
! ...
FUNCTION variance (A,W)

! ... Calculates the variance = FACTOR * Sum (A(i)-mean(A))**2
! ... The value of FACTOR depends of W. By default, W=0, FACTOR = 1/(N-1)
! ... However, if W=1, the biased variance is calculated, i.e. FACTOR=1/N
! ... If W has to be used as a weight it must be a vector with the same
! ... size than A.
! ...
! ... Weights are optional.
! ...
IMPLICIT NONE

! ... Output value
! ...
real(dp) variance

real(dp), DIMENSION(:), INTENT(in)     :: A
real(dp), DIMENSION(:), OPTIONAL       :: W

logicaL                                    :: weight = .false.
logical                                    :: biased = .false.
integer N,i
real(dp) xsum1,xsum2,ai,wi,Sw
real(dp) nan

! ... nan:
! ...
nan = ieee_value(1.0_dp,ieee_quiet_nan)

variance = nan
N = SIZE(A)
IF (N.EQ.0) RETURN

IF (PRESENT(W)) THEN
  IF (SIZE(W).EQ.1) THEN
    IF (W(1).EQ.0) THEN
      biased = .false.
    ELSE IF (W(1).EQ.1) THEN
      biased = .true.
    ELSE
      STOP 'ERROR in variance: Invalid normalization. Use 0 (unbiased) or 1 (biased)'
    ENDIF
  ELSE IF (SIZE(W).EQ.N) THEN
    weight = .true.
  ELSE
    STOP 'ERROR in variance: Size W must be 1 or N'
  ENDIF
ENDIF

IF (weight) THEN
  Sw    = 0D0
  xsum1 = 0D0
  xsum2 = 0D0
  DO i=1,N
    wi = w(i)
    ai = A(i)
    Sw    = Sw    + wi
    xsum1 = xsum1 + wi*ai
    xsum2 = xsum2 + wi*ai*ai
  ENDDO
  xsum1 = xsum1 / Sw
  xsum2 = xsum2/Sw-xsum1*xsum1
  variance = Sw * xsum2 /(Sw - 1D0)
ELSE
  xsum1 = 0D0
  xsum2 = 0D0
  DO i=1,N
    ai = A(i)
    xsum1 = xsum1 + ai
    xsum2 = xsum2 + ai*ai
  ENDDO
  xsum1 = xsum1 / N
  xsum2 = xsum2 / N - xsum1*xsum1
  IF (biased) THEN
    variance = xsum2
  ELSE
    variance = N*xsum2/(N-1D0)
  ENDIF
ENDIF
IF (variance.LT.0) variance = 0D0

END FUNCTION variance
! ...
! =====================================================================
! ...
function arth(first,increment,n)

! ... Array function returning an arithmetic progression

real(dp), intent(in)              :: first,increment
integer, intent(in)               :: n
real(dp), dimension(n)            :: arth

! ... Local variables
! ...
integer k,k2
real(dp) temp

if (n > 0) arth(1) = first
if (n <= NPAR_ARTH) then
  do k=2,n
    arth(k) = arth(k-1) + increment
  enddo
else
  do k=2,NPAR2_ARTH
    arth(k) = arth(k-1) + increment
  enddo
  temp = increment*NPAR2_ARTH
  k = NPAR2_ARTH
  do
    if (k >= n) exit
    k2 = k + k
    arth(k+1:min(k2,n)) = temp + arth(1:min(k,n-k))
    temp = temp + temp
    k = k2
  enddo
endif

end function arth
! ...
! =====================================================================
! ...
subroutine FFT1D(dimx,funcionR,funcionI,signo)

implicit none

integer, intent(in)                         :: dimx,signo
real(dp),dimension(0:dimx-1), intent(inout) :: funcionR,funcionI

! ... Local variables
! ...
real(dp)    :: tempR,tempI
real(dp)    :: wpasoR,wpasoI
real(dp)    :: wwR,wwI
real(dp)    :: ttR,ttI
integer      ix,je,mm,mmax,istep

tempR = 0.0D0
tempI = 0.0D0
je = 1
DO ix=0,dimx-1
  IF(je.GT.ix+1) THEN
    tempR = funcionR(je-1)
    tempI = funcionI(je-1)
    funcionR(je-1) = funcionR(ix)
    funcionI(je-1) = funcionI(ix)
    funcionR(ix) = tempR
    funcionI(ix) = tempI
  ENDIF
  mm = dimx/2
  DO WHILE (mm.GT.1 .AND. je.GT.mm)
    je = je - mm
    mm = mm/2
  ENDDO
  je = je+mm
ENDDO

mmax = 1
DO WHILE (dimx .GT.mmax)
  istep = 2*mmax
  wpasoR = cos(PI/DBLE(mmax))
  wpasoI = signo*sin(PI/DBLE(mmax))
  wwR = 1.0D0
  wwI = 0.0D0
  DO mm = 1,mmax
    DO ix = mm-1,dimx-1,istep
      je = ix+mmax
      CALL c_mult(wwR,wwI,funcionR(je),funcionI(je),tempR,tempI)
      funcionR(je) = funcionR(ix) - tempR
      funcionI(je) = funcionI(ix) - tempI
      funcionR(ix) = funcionR(ix) + tempR
      funcionI(ix) = funcionI(ix) + tempI
    ENDDO
    CALL c_mult(wwR,wwI,wpasoR,wpasoI,ttR,ttI)
    wwR = ttR
    wwI = ttI
  ENDDO
  mmax = istep
ENDDO

RETURN
END SUBROUTINE FFT1D
! ...
! =========================================================================
! ...
SUBROUTINE c_mult (ar,ai,br,bi,cr,ci)

IMPLICIT NONE

REAL(KIND=8), INTENT(in)              :: ar,ai,br,bi
REAL(KIND=8), INTENT(out)             :: cr,ci

cr = ar*br - ai*bi
ci = ar*bi + ai*br

RETURN
END SUBROUTINE c_mult
! ...
! =====================================================================
! ...
subroutine fourrow(data,isign)

! ... Repaces earch row (constant first index) of data(1:M,1:N) by its
! ... discrete Fourier tranform (transform on second incex), if isign
! ... has been set to 1. It replaces each row of data by N times its inverse
! ... discrete Fourier transform if isign is -1.
! ... N must be an integer power of 2.
! ... Parallelistm is M-fold on the first index of data
! ... Numerical Recipes (c)

complex(dp), dimension(:,:), intent(inout)       :: data
integer, intent(in)                              :: isign

! ... Local variables
! ...
integer n,i,istep,j,m,mmax,n2
real(dp) theta
complex(dp) w,wp,ws
complex(dp) temp(size(data,1))

n = size(data,2)
if (iand(n,n-1).ne.0) call stop_error(1,'ERROR: n must be a power of 2 in FOURROW')

n2 = n/2
j  = n2

! ... Bit-reversal section of the routine
! ...
do i=1,n-2
  if (j.gt.i) call swap(data(:,j+1),data(:,i+1))
  m = n2
  do
    if (m.lt.2 .or. j.lt.m) exit
    j = j - m
    m = m / 2
  enddo
  j = j + m
enddo
mmax = 1

! ... Here begins the Daneilson-Lanczos section of the routine
! ... Outer loop executed log2(N) times
do
  if (n.le.mmax) exit
  istep = 2*mmax
  theta = pi/(isign*mmax)
  wp = cmplx(-2.0D0*sin(0.5D0*theta)**2,sin(theta),kind=dp)
  w  = cmplx(1.0D0,0.0D0,kind=dp)
  do m=1,mmax
    ws = w
    do i=m,n,istep
      j = i + mmax
      temp = ws*data(:,j)
      data(:,j) = data(:,i) - temp
      data(:,i) = data(:,i) + temp
    enddo
    w = w*wp + w
  enddo
  mmax = istep
enddo

end subroutine fourrow
! ...
! =====================================================================
! ...
subroutine four1(data,isign)

complex(dp), dimension(:), intent(inout)         :: data
integer, intent(in)                              :: isign

! ... Local variables
! ...
integer n,m1,m2,j
real(dp), dimension(:), allocatable              :: theta
complex(dp), dimension(:), allocatable           :: w,wp
complex(dp), dimension(:,:), allocatable         :: dat,temp

n = size(data)
if (iand(n,n-1).ne.0) call stop_error(1,'ERROR: n must be a power of 2 in FOUR1')

m1 = 2**ceiling(0.5_sp*log(real(n,sp))/0.693147_sp)
m2 = n/m1
allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))

dat=reshape(data,shape(dat))

call fourrow(dat,isign)

theta = arth(0.0D0,dble(isign),m1)*DPI/n
wp = cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dp)
w  = cmplx(1.0_dp,0.0_dp,kind=dp)
do j=2,m2
  w = w*wp+w
  dat(:,j) = dat(:,j)*w
enddo
temp = transpose(dat)

call fourrow(temp,isign)
data = reshape(temp,shape(data))

deallocate(dat,w,wp,theta,temp)

end subroutine four1
! ...
! =====================================================================
! ...
subroutine twofft(data1,data2,fft1,fft2)

real(dp), dimension(:), intent(in)     :: data1,data2
complex(dp), dimension(:), intent(out) :: fft1,fft2

! ... Local variables
! ...
complex(dp), parameter                         :: C1=(0.5_dp, 0.0_dp)
complex(dp), parameter                         :: C2=(0.0_dp,-0.5_dp)
integer n,n2
complex, dimension(size(data1)/2+1) :: h1,h2

if (size(data1).ne.size(data2)) call stop_error (1,'ERROR: incompatible data size in TWOFFT')
if (size(fft1).ne.size(fft2))   call stop_error (1,'ERROR: incompatible data size in TWOFFT')
if (size(data1).ne.size(fft1))  call stop_error (1,'ERROR: incompatible data size in TWOFFT')

n  = size(data1)
if (iand(n,n-1).ne.0) call stop_error(1,'ERROR: n must be a power of 2 in FOUR1')

n2 = n/2+1

fft1 = cmplx(data1,data2,kind=dp) ! Pack the two real arrays into one complex array.

call four1(fft1,1)               ! Transform the complex array.
fft2(1) = cmplx(aimag(fft1(1)),0.0_dp,kind=dp)
fft1(1) = cmplx(real(fft1(1)),0.0_dp,kind=dp)

h1(2:n2) = C1*(fft1(2:n2)+conjg(fft1(n:n2:-1)))   ! Use symmetries to separate the
h2(2:n2) = C2*(fft1(2:n2)-conjg(fft1(n:n2:-1)))   ! two transforms

fft1(2:n2)=h1(2:n2)
fft1(n:n2:-1)=conjg(h1(2:n2))

fft2(2:n2)=h2(2:n2)
fft2(n:n2:-1)=conjg(h2(2:n2))

end subroutine twofft
! ...
! =====================================================================
! ...
subroutine realft(data,isign,zdata)

real(dp), dimension(:), intent(inout)             :: data
integer                                           :: isign
complex(dp), dimension(:), optional, target       :: zdata

! ... Local variables
! ...
integer n,nh,nq
real(dp)                                          :: c1=0.5D0,c2
complex(dp)                                       :: z
complex(dp), dimension(size(data)/4)              :: w
complex(dp), dimension(size(data)/4-1)            :: h1,h2
complex(dp), dimension(:), pointer                :: cdata

n = size(data)
if (iand(n,n-1).ne.0) call stop_error(1,'ERROR: n must be a power of 2 in FOUR1')

nh = n/2
nq = n/4
if (present(zdata)) then
  if (size(zdata).ne.nh) call stop_error(1,'Error in REALFT')
  cdata => zdata
  if (isign == 1) cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=dp)
else
  allocate (cdata(nh))
  cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=dp)
endif
if (isign == 1) then
  c2 = -0.5D0
  call four1(cdata,+1)
else
  c2 = 0.5D0
endif

w = zroots_unity(sign(n,isign),nq)
w = cmplx(-aimag(w),real(w),kind=dp)
h1 = c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
h2 = c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
cdata(2:nq)       = h1 + w(2:nq)*h2
cdata(nh:nq+2:-1) = conjg(h1 - w(2:nq)*h2)
z = cdata(1)
if (isign == 1) then
  cdata(1) = cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=dp)
else
  cdata(1) = cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=dp)
  call four1(cdata,-1)
end if

if (present(zdata)) then
  if (isign .ne. 1) then
    data(1:n-1:2) = real(cdata)
    data(2:n:2)   = aimag(cdata)
  end if
else
  data(1:n-1:2) = real(cdata)
  data(2:n:2)   = aimag(cdata)
  deallocate(cdata)
end if

end subroutine realft
! ...
! =====================================================================
! ...
function zroots_unity(n,nn)
! Complex function returning nn powers of the n-th root of unity.
integer, intent(in)                          :: n,nn
complex(dp), dimension(nn)                   :: zroots_unity

! ... Local variables
! ...
integer k
real(dp) theta

zroots_unity(1) = 1.0D0
theta = dpi/n
k = 1
do
  if (k >= nn) exit
  zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),kind=dp)
  zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*zroots_unity(2:min(k,nn-k))
  k = 2*k
enddo

end function zroots_unity
! ...
! =====================================================================
! ...
function correl(data1,data2)

! ... Computes the correlation of two real sets data1 and data2
! ... of length N (including any user-supplied zero padding). N must
! ... be an integer power of two. The answer is returned as the
! ... function correl(N).
! ... The answer is stored in wrap-around order, i.e. correlations
! ... at increasingly negative lags are in correl(N) on down to correl(n/2+1),
! ... while correlation at nicreasingly positive lags are in correl(1) (zero lag)
! ... on up to correl(n/2).
! ... Sign convention of this routine: if data1 lags data2, i.e. is shifted to the
! ... right of it, then correl will whow a peak in positive lags.
! ...
real(dp), dimension(:), intent(inout)             :: data1,data2
real(dp), dimension(size(data1))                  :: correl

! ... Local variables
! ...
integer n,no2
complex(dp), dimension(size(data1)/2)             :: cdat1,cdat2

n = size(data1)
if (iand(n,n-1).ne.0) call stop_error(1,'ERROR: n must be a power of 2 in CORREL')
if (size(data2).ne.n) call stop_error(1,'Incompatible data dimension in CORREL')

no2 = n / 2

call realft(data1,1,cdat1)      ! Transform both data vectors.
call realft(data2,1,cdat2)

! ... Multiply to find the FFT of their correlation
! ...
cdat1(1)=cmplx(real(cdat1(1))*real(cdat2(1))/no2, &
               aimag(cdat1(1))*aimag(cdat2(1))/no2, kind=dp)
cdat1(2:)=cdat1(2:)*conjg(cdat2(2:))/no2

call realft(correl,-1,cdat1) ! Inverse transform gives correlation.

end function correl
! ...
! =====================================================================
! ...
end module module_math


 SUBROUTINE build_coeff_3D_Cos (ETA, beta, N, Hs, Tp, DELT, SEED, seed2, beta0, s0, gamma)
!
! This subroutine returns Z(w) and kvec, the Fourier transform of
! the wave elevation, zeta(t) and a direction beta(w) for each frequency.
! The coefficients are based on a JONSWAP spectrum with a cos^(2s0) spreading
! around the heading angle beta0.
!
   IMPLICIT none
   integer, parameter :: long=selected_real_kind(12,99)
   INTEGER SEED, seed2, n, ncta
   REAL(kind=long) :: Hs, Tp, delt, beta0, s0, gamma
   REAL(kind=long) :: ETA(n), beta(n)
   ! Locals
   Integer i
   REAL gasdev, ran1_b
   REAL(kind=long) ::  pi,  df, cst, freq, spec, sf,amp,mr0,           &
        jonswap_spectrum, zero=0._long,                                &
        one=1._long, two=2._long, four=4._long, half=.5_long,          &
        twopi, ran1, psi, mag, deg2rad, fp, sigma, erf1, erf2,         &
        rad2deg
   COMPLEX(kind=long) :: phase
   EXTERNAL gasdev, ran1_b, jonswap_spectrum
!
! Open the file to write the spectral coeficients out to
!
   open(unit=78,file='spectrum',status='unknown')
   write(78,79)
79 format('# Spectrum for the directional random wave wavemaker signal. f, T, S(f), beta(f)')

   pi = acos(-one)
   twopi = two * pi
   deg2rad=pi/180._long; rad2deg=1/deg2rad
   df = one / (n * delt)
   cst = sqrt(df)
   fp=1/Tp

   ncta=n/2              !!  number of angles

   !  m0
   mr0=0.0
   DO i = 1,n
      freq=i*df
      sf= jonswap_spectrum(freq, Hs, Tp, gamma)
      mr0=mr0+sf*df
   END DO

   amp=sqrt(2.0*mr0/real(n/2.0))

   ! Initialize
   beta(:)=beta0

   ! Take care of zero and Nyquist frequencies.
   eta (1) = zero;
   eta (2) = zero

   !    get the angle from spreading

   CALL spreading(beta,pi,s0,beta0,seed2,ncta)

   do i=1,n

      beta(i)=beta(i)*rad2deg
   end do

   ! Build the Fourier coefficients using the chosen Spectrum and a random
   ! phase.  Each frequency has one heading angle which is also based on this
   ! random number and the accumulated PDF of the spectrum.

   DO  i = 2, n / 2
      freq = (i - 1) * df
      psi=ran1_b(seed2)
      !
      ! Choose here whether the Fourier amplitudes should be exactly on the spectrum
      ! or Gaussianly distributed around the spectral value.
      !
      mag=one
      !      mag=gasdev(seed)  ! This will give a Guassian distribution of magnitude.
      !
      phase=mag*cmplx(cos(twopi*psi),sin(twopi*psi))

      ! Get the wave spectrum value and the direction at this frequency.

      spec= jonswap_spectrum(freq, Hs, Tp, gamma)

      !
      ! Write the spectral coefficients for inspection.
      !
      write(78,*)freq,1/freq,spec,beta(i)
      !
      ! Load the Fourier coefficients for this frequency
      !
      ! Real part
      eta (2*i-1) = REAL(sqrt (two * spec) * cst * phase)

      ! Imaginary part
      eta (2*i)= AIMAG(sqrt (two * spec) * cst * phase)

   END DO
   close(78)

   RETURN
 END SUBROUTINE BUILD_COEFF_3D_COS


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================

! Riemann solver for the sample scalar equation
!  q_t + u*q_x + v*q_y = 0

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.
! On output, wave contains the waves,
!            s the speeds,
!
!            amdq = A^- Delta q,
!            apdq = A^+ Delta q,
!                   the decomposition of the flux difference
!                       f(qr(i-1)) - f(ql(i))
!                   into leftgoing and rightgoing parts respectively.
!

! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                    and right state ql(:,i)
! From the basic clawpack routines, this routine is called with ql = qr
! maux=0 and aux arrays are unused in this example.

    implicit double precision (a-h,o-z)
    common /cparam/ u,v

    dimension wave(meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves, 1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension  apdq(meqn, 1-mbc:maxm+mbc)
    dimension  amdq(meqn, 1-mbc:maxm+mbc)

!$$$      do 30 i = 2-mbc, mx+mbc-1
    do 30 i = 2-mbc, mx+mbc
        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        if (ixy == 1) then
            s(1,i) = u
        else
            s(1,i) = v
        endif

    !        # flux differences:
        amdq(1,i) = dmin1(s(1,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(s(1,i), 0.d0) * wave(1,1,i)

    30 END DO

    return
    end subroutine rpn2


#include "scalar.fpp"

!=====================================================================!
! One dimensional unsteady tranport physics.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module unsteady_transport_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: unsteady_transport

  !-------------------------------------------------------------------!
  ! Type that implements first order transport equations
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: unsteady_transport

     type(scalar) :: dx
     type(scalar) :: conv_speed
     type(scalar) :: diff_coeff

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: add_jacobian_vector_product => add_jacobian_vector_product
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type unsteady_transport

  ! Interface to construct the physical system
  interface unsteady_transport
     procedure construct_unsteady_transport
  end interface unsteady_transport

contains

  !===================================================================!
  ! Constructor for unsteady transport physics
  !===================================================================!

  type(unsteady_transport) function construct_unsteady_transport( &
       & diffusion_coeff, convective_velocity, &
       & bounds, npts, sparse) result (this)

    type(scalar), intent(in) :: diffusion_coeff, convective_velocity
    type(scalar), intent(in) :: bounds(2)
    integer     , intent(in) :: npts
    logical     , intent(in) :: sparse

    type(scalar) :: dx
    integer      :: i

    call this % set_description('Unsteady Transport')

    ! Set time order of physical system
    call this % set_differential_order(1)

    ! System parameters
    this % conv_speed = convective_velocity
    this % diff_coeff = diffusion_coeff

    ! Sparse or dense assembly
    this % sparse = sparse

    ! Use FD jacobian or supplied jacobian
    this % approximate_jacobian = .false.

    ! Node locations
    allocate(this % X(3,npts+2)); this % X = 0.0_wp;
    this % dx = (bounds(2) - bounds(1))/dble(npts+1)
    do i = 1, npts + 2
       this % X(1,i) = bounds(1) + dble(i-1)*this % dx
    end do

    ! Set the number of state variables based on spatial
    ! discretization of the governing equations
    call this % set_num_state_vars(npts+2) ! include boundary nodes in system

  end function construct_unsteady_transport

  !===================================================================!
  ! Destructor for unsteady transport physics
  !===================================================================!

  pure subroutine destruct(this)

    type(unsteady_transport), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(unsteady_transport), intent(inout) :: this
    type(scalar)             , intent(inout) :: residual(:)
    type(scalar)             , intent(in)    :: U(:,:)
    type(scalar)             , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: a, b, c
    real(wp) :: d, e
    integer :: i

    d = 0.0d0
    e = 0.0d0
    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff)

    a = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
    b = 2.0_wp*gamma/(this % dx*this % dx)
    c = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

    ! Residual with BC applied
    residual(1) = residual(1) + phidot(1) + phi(1) - d
    forall(i = 2 : npts-1)
       residual(i) = residual(i) + phidot(i) + a*phi(i-1) + b*phi(i) + c*phi(i+1)
    end forall
    residual(npts) = residual(npts) + phidot(npts) + phi(npts) - e

  end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(unsteady_transport) , intent(inout) :: this
    type(scalar)              , intent(inout) :: jacobian(:,:)
    type(scalar)              , intent(in)    :: coeff(:)
    type(scalar)              , intent(in)    :: U(:,:)
    type(scalar)              , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: aa, bb, cc
    integer      :: i, j

    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff, &
         & alpha=>coeff(1), beta=>coeff(2))

      aa = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
      bb = 2.0_wp*gamma/(this % dx*this % dx)
      cc = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

      if (this % sparse .eqv. .true.) then

         jacobian(1,:) = jacobian(1,:) + [0.0d0, beta*1.0d0 + alpha*1.0d0, 0.0d0]
         do concurrent(i = 2:npts-1)
            jacobian(i,:) = jacobian(i,:) + [alpha*aa, beta + alpha*bb, alpha*cc]
         end do
         jacobian(npts,:) = jacobian(npts,:) + [0.0d0, beta*1.0d0 + alpha*1.0d0, 0.0d0]

      else

         jacobian(1,1) = beta*1.0d0 + alpha*1.0d0
         do i = 2, npts-1
            do j = 1, npts
               if (i .eq. j-1) then
                  ! upper diagonal
                  jacobian(i,j) = jacobian(i,j) + alpha*cc
               else if (i .eq. j) then
                  ! diagonal
                  jacobian(i,i) = jacobian(i,j) + beta + alpha*bb
               else if (i .eq. j+1) then
                  ! lower diagonal
                  jacobian(i,j) = jacobian(i,j) + alpha*aa
               else
               end if
            end do
         end do
         jacobian(npts,npts) = beta*1.0d0 + alpha*1.0d0

      end if

    end associate

  end subroutine add_jacobian

  !=====================================================================!
  ! Routine to return the product of jacobian matrix with a compatible
  ! vector.
  !=====================================================================!

  pure subroutine add_jacobian_vector_product(this, pdt, vec, scalars, U, X)

    class(unsteady_transport), intent(inout) :: this
    type(scalar)   , intent(inout) :: pdt(:)
    type(scalar)   , intent(in)    :: vec(:)
    type(scalar)   , intent(in)    :: scalars(:)
    type(scalar)   , intent(in)    :: U(:,:)
    type(scalar)   , intent(in)    :: X(:,:)

    ! Locals
    type(scalar) :: aa, bb, cc
    integer      :: i, j

    associate(phi=>U(1,:), phidot=> U(2,:), &
         & npts=>this % get_num_state_vars(), &
         & vel=>this % conv_speed, gamma => this % diff_coeff, &
         & alpha=>scalars(1), beta=>scalars(2))

      aa = -(vel/(2.0_wp*this % dx) + gamma/(this % dx*this % dx))
      bb = 2.0_wp*gamma/(this % dx*this % dx)
      cc = (vel/(2.0_wp*this % dx) - gamma/(this % dx*this % dx))

      if (this % sparse .eqv. .true.) then

!!$         pdt(1) = pdt(1) + dot_product([beta + alpha*bb, alpha*cc], vec(1:2))
!!$
!!$         !jacobian(1,:) = jacobian(1,:) + [0.0d0, beta + alpha*bb, alpha*cc]
!!$         do concurrent(i = 2 : npts-1)
!!$            !pdt(i) = pdt(i) +
!!$            pdt(i) = pdt(i) + dot_product([alpha*aa, beta + alpha*bb, alpha*cc], vec(i-1:i+1))
!!$            !jacobian(i,:) =  jacobian(i,:) + [alpha*aa, beta + alpha*bb, alpha*cc]
!!$         end do
!!$         !         pdt(npts) = pdt(npts) +
!!$         pdt(npts) = pdt(npts) + dot_product([alpha*aa, beta + alpha*bb], vec(npts-1:npts))
!!$         !jacobian(npts,:) = jacobian(npts,:) + [alpha*aa, beta + alpha*bb, 0.0d0]

      else

!!$         do i = 1, npts
!!$            do j = 1, npts
!!$               if (i .eq. j-1) then
!!$                  ! upper diagonal
!!$                  !jacobian(i,j) = jacobian(i,j) + alpha*cc
!!$               else if (i .eq. j) then
!!$                  ! diagonal
!!$                  !jacobian(i,i) = jacobian(i,j) + beta + alpha*bb
!!$               else if (i .eq. j+1) then
!!$                  ! lower diagonal
!!$                  !jacobian(i,j) = jacobian(i,j) + alpha*aa
!!$               else
!!$               end if
!!$            end do
!!$         end do

      end if

    end associate

  end subroutine add_jacobian_vector_product

  !===================================================================!
  ! Sets the initial condition for use in the integator.
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(unsteady_transport), intent(in)    :: this
    type(scalar)             , intent(inout) :: U(:,:)
    type(scalar)             , intent(in)    :: X(:,:)
    type(scalar) :: pi
    integer :: i

    pi = 4.0_wp*atan(1.0_wp)

    associate(phi=>U(1,:), x=>this%X(1,:))

      do i=1,this % get_num_state_vars()
         phi(i) = (0.4_wp*pi)**(-0.5_wp)*exp(-2.5_wp*(x(i)-10.0_wp)*(x(i)-10.0_wp))
      end do

    end associate

  end subroutine get_initial_condition

end module unsteady_transport_class


!==============================================================================!
  subroutine Compute_Gradient_Matrix(grid, boundary)
!------------------------------------------------------------------------------!
!   Calculates gradient matrix.                                                !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  logical         :: boundary
!-----------------------------------[Locals]-----------------------------------!
  integer :: c, c1, c2, s
  real    :: dx_c1, dy_c1, dz_c1, dx_c2, dy_c2, dz_c2
  real    :: jac, g_inv(6)
!==============================================================================!

  do c = 1, grid % n_cells
    g(1,c) = 0.0
    g(2,c) = 0.0
    g(3,c) = 0.0
    g(4,c) = 0.0
    g(5,c) = 0.0
    g(6,c) = 0.0
  end do

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    dx_c1 = grid % dx(s)
    dy_c1 = grid % dy(s)
    dz_c1 = grid % dz(s)
    dx_c2 = grid % dx(s)
    dy_c2 = grid % dy(s)
    dz_c2 = grid % dz(s)

    ! With boundary cells, velocities, temperatures
    if(boundary) then
      g(1,c1)=g(1,c1) + dx_c1*dx_c1    ! 1,1
      g(2,c1)=g(2,c1) + dy_c1*dy_c1    ! 2,2
      g(3,c1)=g(3,c1) + dz_c1*dz_c1    ! 3,3
      g(4,c1)=g(4,c1) + dx_c1*dy_c1    ! 1,2  &  2,1
      g(5,c1)=g(5,c1) + dx_c1*dz_c1    ! 1,3  &  3,1
      g(6,c1)=g(6,c1) + dy_c1*dz_c1    ! 2,3  &  3,2
      if(c2 > 0) then  ! this is enough even for parallel
        g(1,c2)=g(1,c2) + dx_c2*dx_c2  ! 1,1
        g(2,c2)=g(2,c2) + dy_c2*dy_c2  ! 2,2
        g(3,c2)=g(3,c2) + dz_c2*dz_c2  ! 3,3
        g(4,c2)=g(4,c2) + dx_c2*dy_c2  ! 1,2  &  2,1
        g(5,c2)=g(5,c2) + dx_c2*dz_c2  ! 1,3  &  3,1
        g(6,c2)=g(6,c2) + dy_c2*dz_c2  ! 2,3  &  3,2
      end if

    ! Without boundary cells => pressure
    else ! Don't use boundary
      if(c2 > 0) then
        g(1,c1)=g(1,c1) + dx_c1*dx_c1  ! 1,1
        g(2,c1)=g(2,c1) + dy_c1*dy_c1  ! 2,2
        g(3,c1)=g(3,c1) + dz_c1*dz_c1  ! 3,3
        g(4,c1)=g(4,c1) + dx_c1*dy_c1  ! 1,2  &  2,1
        g(5,c1)=g(5,c1) + dx_c1*dz_c1  ! 1,3  &  3,1
        g(6,c1)=g(6,c1) + dy_c1*dz_c1  ! 2,3  &  3,2

        g(1,c2)=g(1,c2) + dx_c2*dx_c2  ! 1,1
        g(2,c2)=g(2,c2) + dy_c2*dy_c2  ! 2,2
        g(3,c2)=g(3,c2) + dz_c2*dz_c2  ! 3,3
        g(4,c2)=g(4,c2) + dx_c2*dy_c2  ! 1,2  &  2,1
        g(5,c2)=g(5,c2) + dx_c2*dz_c2  ! 1,3  &  3,1
        g(6,c2)=g(6,c2) + dy_c2*dz_c2  ! 2,3  &  3,2
      end if
    end if ! boundary
  end do

  !----------------------------------!
  !   Find the inverse of matrix g   !
  !----------------------------------!
  do c = 1, grid % n_cells
    jac  =         g(1,c) * g(2,c) * g(3,c)  &
           -       g(1,c) * g(6,c) * g(6,c)  &
           -       g(4,c) * g(4,c) * g(3,c)  &
           + 2.0 * g(4,c) * g(5,c) * g(6,c)  &
           -       g(5,c) * g(5,c) * g(2,c)

    g_inv(1) = +( g(2,c)*g(3,c) - g(6,c)*g(6,c) ) / (jac+TINY)
    g_inv(2) = +( g(1,c)*g(3,c) - g(5,c)*g(5,c) ) / (jac+TINY)
    g_inv(3) = +( g(1,c)*g(2,c) - g(4,c)*g(4,c) ) / (jac+TINY)
    g_inv(4) = -( g(4,c)*g(3,c) - g(5,c)*g(6,c) ) / (jac+TINY)
    g_inv(5) = +( g(4,c)*g(6,c) - g(5,c)*g(2,c) ) / (jac+TINY)
    g_inv(6) = -( g(1,c)*g(6,c) - g(4,c)*g(5,c) ) / (jac+TINY)

    g(1,c) = g_inv(1)
    g(2,c) = g_inv(2)
    g(3,c) = g_inv(3)
    g(4,c) = g_inv(4)
    g(5,c) = g_inv(5)
    g(6,c) = g_inv(6)
  end do

  end subroutine


C******************************************************************************
C FILE: omp_workshare2.f
C DESCRIPTION:
C   OpenMP Example - Sections Work-sharing - Fortran Version
C   In this example, the OpenMP SECTION directive is used to assign
C   different array operations to each thread that executes a SECTION.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED: 07/16/07
C******************************************************************************

      PROGRAM WORKSHARE2

      INTEGER N, I, NTHREADS, TID, OMP_GET_NUM_THREADS,
     +        OMP_GET_THREAD_NUM
      PARAMETER (N=50)
      REAL A(N), B(N), C(N), D(N)

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.5
        B(I) = I + 22.35
        C(N) = 0.0
        D(N) = 0.0
      ENDDO

!$OMP PARALLEL SHARED(A,B,C,D,NTHREADS), PRIVATE(I,TID)
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads =', NTHREADS
      END IF
      PRINT *, 'Thread',TID,' starting...'

!$OMP SECTIONS

!$OMP SECTION
      PRINT *, 'Thread',TID,' doing section 1'
      DO I = 1, N
         C(I) = A(I) + B(I)
         WRITE(*,100) TID,I,C(I)
 100     FORMAT(' Thread',I2,': C(',I2,')=',F8.2)
      ENDDO

!$OMP SECTION
      PRINT *, 'Thread',TID,' doing section 2'
      DO I = 1, N
         D(I) = A(I) * B(I)
         WRITE(*,100) TID,I,D(I)
      ENDDO

!$OMP END SECTIONS NOWAIT

      PRINT *, 'Thread',TID,' done.'

!$OMP END PARALLEL

      END


*DECK ORTHOR
      SUBROUTINE ORTHOR (A, N, M, NRDA, IFLAG, IRANK, ISCALE, DIAG,
     +   KPIVOT, SCALES, ROWS, RS)
C***BEGIN PROLOGUE  ORTHOR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (ORTHOR-S, DORTHR-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   Reduction of the matrix A to lower triangular form by a sequence of
C   orthogonal HOUSEHOLDER transformations post-multiplying A
C
C   Modeled after the ALGOL codes in the articles in the REFERENCES
C   section.
C
C **********************************************************************
C   INPUT
C **********************************************************************
C
C     A -- Contains the matrix to be decomposed, must be dimensioned
C           NRDA by N
C     N -- Number of rows in the matrix, N greater or equal to 1
C     M -- Number of columns in the matrix, M greater or equal to N
C     IFLAG -- Indicates the uncertainty in the matrix data
C             = 0 when the data is to be treated as exact
C             =-K when the data is assumed to be accurate to about
C                 K digits
C     ISCALE -- Scaling indicator
C               =-1 if the matrix is to be pre-scaled by
C               columns when appropriate.
C               Otherwise no scaling will be attempted
C     NRDA -- Row dimension of A, NRDA greater or equal to N
C     DIAG,KPIVOT,ROWS -- Arrays of length at least N used internally
C         ,RS,SCALES         (except for SCALES which is M)
C
C **********************************************************************
C   OUTPUT
C **********************************************************************
C
C     IFLAG - status indicator
C            =1 for successful decomposition
C            =2 if improper input is detected
C            =3 if rank of the matrix is less than N
C     A -- contains the reduced matrix in the strictly lower triangular
C          part and transformation information
C     IRANK -- contains the numerically determined matrix rank
C     DIAG -- contains the diagonal elements of the reduced
C             triangular matrix
C     KPIVOT -- Contains the pivotal information, the column
C               interchanges performed on the original matrix are
C               recorded here.
C     SCALES -- contains the column scaling parameters
C
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  G. Golub, Numerical methods for solving linear least
C                 squares problems, Numerische Mathematik 7, (1965),
C                 pp. 206-216.
C               P. Businger and G. Golub, Linear least squares
C                 solutions by Householder transformations, Numerische
C                 Mathematik  7, (1965), pp. 269-276.
C***ROUTINES CALLED  CSCALE, R1MACH, SDOT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ORTHOR
      DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),ROWS(*),RS(*),SCALES(*)
C
C END OF ABSTRACT
C
C **********************************************************************
C
C     MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C     BY THE FUNCTION R1MACH.
C
C **********************************************************************
C
C***FIRST EXECUTABLE STATEMENT  ORTHOR
      URO = R1MACH(4)
      IF (M .GE. N  .AND.  N .GE. 1  .AND.  NRDA .GE. N) GO TO 1
      IFLAG=2
      CALL XERMSG ('SLATEC', 'ORTHOR', 'INVALID INPUT PARAMETERS.', 2,
     +   1)
      RETURN
C
    1 ACC=10.*URO
      IF (IFLAG .LT. 0) ACC=MAX(ACC,10.**IFLAG)
      SRURO=SQRT(URO)
      IFLAG=1
      IRANK=N
C
C     COMPUTE NORM**2 OF JTH ROW AND A MATRIX NORM
C
      ANORM=0.
      DO 2 J=1,N
         KPIVOT(J)=J
         ROWS(J)=SDOT(M,A(J,1),NRDA,A(J,1),NRDA)
         RS(J)=ROWS(J)
         ANORM=ANORM+ROWS(J)
    2 CONTINUE
C
C     PERFORM COLUMN SCALING ON A WHEN SPECIFIED
C
      CALL CSCALE(A,NRDA,N,M,SCALES,DUM,ROWS,RS,ANORM,SCALES,ISCALE,1)
C
      ANORM=SQRT(ANORM)
C
C
C     CONSTRUCTION OF LOWER TRIANGULAR MATRIX AND RECORDING OF
C     ORTHOGONAL TRANSFORMATIONS
C
C
      DO 50 K=1,N
         MK=M-K+1
         IF (K .EQ. N) GO TO 25
         KP=K+1
C
C        SEARCHING FOR PIVOTAL ROW
C
         DO 10 J=K,N
            IF (ROWS(J) .GE. SRURO*RS(J)) GO TO 5
            ROWS(J)=SDOT(MK,A(J,K),NRDA,A(J,K),NRDA)
            RS(J)=ROWS(J)
    5       IF (J .EQ. K) GO TO 7
            IF (SIGMA .GE. 0.99*ROWS(J)) GO TO 10
    7       SIGMA=ROWS(J)
            JROW=J
   10    CONTINUE
         IF (JROW .EQ. K) GO TO 25
C
C        PERFORM ROW INTERCHANGE
C
         L=KPIVOT(K)
         KPIVOT(K)=KPIVOT(JROW)
         KPIVOT(JROW)=L
         ROWS(JROW)=ROWS(K)
         ROWS(K)=SIGMA
         RSS=RS(K)
         RS(K)=RS(JROW)
         RS(JROW)=RSS
         DO 20 L=1,M
            ASAVE=A(K,L)
            A(K,L)=A(JROW,L)
   20       A(JROW,L)=ASAVE
C
C        CHECK RANK OF THE MATRIX
C
   25    SIG=SDOT(MK,A(K,K),NRDA,A(K,K),NRDA)
         DIAGK=SQRT(SIG)
         IF (DIAGK .GT. ACC*ANORM) GO TO 30
C
C        RANK DEFICIENT PROBLEM
         IFLAG=3
         IRANK=K-1
         CALL XERMSG ('SLATEC', 'ORTHOR',
     +      'RANK OF MATRIX IS LESS THAN THE NUMBER OF ROWS.', 1, 1)
         RETURN
C
C        CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A
C
   30    AKK=A(K,K)
         IF (AKK .GT. 0.) DIAGK=-DIAGK
         DIAG(K)=DIAGK
         A(K,K)=AKK-DIAGK
         IF (K .EQ. N) GO TO 50
         SAD=DIAGK*AKK-SIG
         DO 40 J=KP,N
            AS=SDOT(MK,A(K,K),NRDA,A(J,K),NRDA)/SAD
            DO 35 L=K,M
   35          A(J,L)=A(J,L)+AS*A(K,L)
   40       ROWS(J)=ROWS(J)-A(J,K)**2
   50 CONTINUE
C
C
      RETURN
      END


C NCLFORTSTART
      subroutine dimsumwgt(nx, x, xmsg, wgt, iopt, sumx)
      implicit none
C                                 INPUT
      integer  nx, iopt
      double precision x(nx), wgt(nx), xmsg
C                                 OUTPUT
      double precision sumx
C NCLEND
      integer n, npts
      double precision xsum

C NCL:  xWgtSum = dim_sum_wgt(x, wgt, opt)

      sumx = xmsg
      xsum = 0.d0
      npts = 0

      do n=1,nx
         if (x(n).ne.xmsg) then
             xsum = xsum + x(n)*wgt(n)
             npts = npts + 1
         end if
      end do

      if (npts.gt.0) then
          if (npts.eq.nx .or. iopt.eq.1) then
              sumx = xsum
              return
          end if

          if (npts.ge.iopt) then
              sumx = xsum
              return
          end if
      end if

      return
      end


      subroutine odrayl ( wl,
     a                   tray)
      double precision a1,a2,a3,a4,awl,an,a
      real wl,tray,z,p,t,wh,wo,delta,sigma,pi,ak,dppt,sr
      integer k
c     molecular optical depth

      common /sixs_atm/ z(34),p(34),t(34),wh(34),wo(34)
      common /sixs_del/ delta,sigma
      real ns
      data pi /3.1415926/
      ak=1/wl
      awl=wl

c     air refraction index edlen 1966 / metrologia,2,71-80  putting pw=0
      a1=130.-ak*ak
      a2=38.9-ak*ak
      a3=2406030./a1
      a4=15997./a2
      an=(8342.13+a3+a4)*1.0e-08
      an=an+1.d+00
      a=(24.*pi**3)*((an*an-1.)**2)*(6.+3.*delta)/(6.-7.*delta)
     s        /((an*an+2.)**2)
      tray=0.
      do k=1,33
        ns=2.54743e+19
        dppt=(288.15/1013.25)*(p(k)/t(k)+p(k+1)/t(k+1))/2.
        sr=(a*dppt/(awl**4)/ns*1.e+16)*1.e+05
        tray=tray+(z(k+1)-z(k))*sr
      enddo

      return
      end


subroutine dtcon

! set the timestep using various constraints.
! NB - additional constraints may be required depending on the problem!
!-----------------------------------------------------------------------

! GLOBALS
use global
use zone
use mpi

IMPLICIT NONE

! LOCALS
INTEGER :: i, j, k, mpierr
REAL ::  ridt, rodt, dtx, dt3, xvel, yvel, zvel, width, widthy, widthz, sinthe

!------------------------------------------------------------------------
!   Hydro constraint on timestep.
ridt = 0.

do k = 1, ks
 do j = 1, js
  sinthe = sin(zyc(j+mypey*js))
  do i = 1, imax
    widthy = zdy(j+mypey*js)
    widthz = zdz(k+mypez*ks)
    if(ngeomy >  2) widthy = widthy*zxc(i)
    if(ngeomz >  2) widthz = widthz*zxc(i)
    if(ngeomz == 5) widthz = widthz*sinthe
    xvel = abs(zux(i,j,k)) / zdx(i)
    yvel = abs(zuy(i,j,k)) / widthy
    zvel = abs(zuz(i,j,k)) / widthz
    ridt = max(xvel,yvel,zvel,ridt)
  enddo
 enddo
enddo

ridt = max(svel,ridt)
call MPI_ALLREDUCE( ridt, rodt, 1, VH1_DATATYPE, MPI_MAX, MPI_COMM_WORLD, mpierr )

dtx  = courant / rodt     ! global time constraint for given courant parameter
dt3  = 1.1 * dt           ! limiting constraint on rate of increase of dt
dt   = min( dt3, dtx )    ! use smallest required timestep

if (time/dt > 1.e8) then   ! if timestep becomes too small, stop the program!
  if (mype == 0) then
    write(*,*) 'Timestep has become too small: dt = ',dt
    write(*,*) '                             time = ',time
  endif
  call prin
  call MPI_FINALIZE(mpierr)
  stop
endif

return
end


SUBROUTINE evolve_disc(t_interp,timeup)
  ! Subroutine interpolates disc models in time (given input time value), and in space

  use stardata
  use eosdata
  use embryodata

  implicit none

  integer :: i,j,k,l,timeup

real :: t_interp, rad
real :: begintime,finishtime

!  real :: grad1, grad2, inter1,inter2, grad,inter, t_interp, rad
!  real :: sdens1,sdens2,Tmid1,Tmid2, nu_pl1,nu_pl2,tau1,tau2
!  real :: alphamid1, alphamid2,begintime,finishtime

  mdisc = 0.0

  ! Find time location first

  i=1
  DO WHILE(timemod(i) < t_interp)
     i = i+1
     IF(i> ntime_mod) THEN
        print*, 'Time up: t=',timemod(i-1)/yr
        timeup = 1
        return
     ENDIF
  ENDDO

  ! If at beginning of file , mstar equal to initial value
  IF(i==1) THEN

     mstar =mstar_mod(i)

     ! Otherwise interpolate in time
     ELSE
        begintime = timemod(i-1)
        finishtime = timemod(i)

     CALL interpolate_1D(t_interp,mstar, begintime,finishtime,mstar_mod(i-1),mstar_mod(i))

  ENDIF

! Now do disc properties:

  IF(i==1) THEN

     do k=1,nrannuli

        rad = r_d(k)
        rout = rad
        irout = k

        j=1
        DO WHILE(r_mod(i,j) < rad.and. j<nrad_mod)
           j=j+1
        ENDDO

        ! If at the beginning spatial index, interpolate against zero

        IF(j==1) THEN

           ! Sigma
           CALL interpolate_1D(r_d(k), sigma_d(k),0.0,r_mod(i,j),0.0, sigma_mod(i,j))

           !print*, 'Sigma done for j=1'
           ! Nu
           CALL interpolate_1D(r_d(k), nu_d(k),0.0,r_mod(i,j),0.0, nu_mod(i,j))

           ! T
           CALL interpolate_1D(r_d(k), T_d(k),0.0,r_mod(i,j),0.0, Tc_mod(i,j))

           ! Alpha
           CALL interpolate_1D(r_d(k), alpha_d(k),0.0,r_mod(i,j),0.0, alpha_mod(i,j))

           ! Tau
           CALL interpolate_1D(r_d(k), tau_d(k),0.0,r_mod(i,j),0.0, tau_mod(i,j))

           ! Otherwise interpolate as normal in space
        ELSE

           ! Sigma
           CALL interpolate_1D(r_d(k), sigma_d(k),r_mod(i,j-1),r_mod(i,j),sigma_mod(i,j-1), sigma_mod(i,j))

           ! Nu
           CALL interpolate_1D(r_d(k), nu_d(k),r_mod(i,j-1),r_mod(i,j),nu_mod(i,j-1), nu_mod(i,j))

           ! T
           CALL interpolate_1D(r_d(k), T_d(k),r_mod(i,j-1),r_mod(i,j),Tc_mod(i,j-1), Tc_mod(i,j))

           ! Alpha
           CALL interpolate_1D(r_d(k), alpha_d(k),r_mod(i,j-1),r_mod(i,j),alpha_mod(i,j-1), alpha_mod(i,j))

           ! Tau
           CALL interpolate_1D(r_d(k), tau_d(k),r_mod(i,j-1),r_mod(i,j),tau_mod(i,j-1), tau_mod(i,j))

        ENDIF

        ! Calculate ancillary variables from interpolated data

        omega_d(k) = sqrt(G*mstar/r_d(k)*r_d(k)*r_d(k))
        H_d(k) = cs_d(k)/omega_d(k)

        mdisc = mdisc + twopi*r_d(k)*sigma_d(k)*dr
   !  If the maximum model disc radius is reached, record and exit the routine

        IF(j>nrad_mod) THEN
           print*, 'Maximum model radius reached'
           DO l=k,nrannuli
              sigma_d(l) = 0.0
              nu_d(l) = 0.0
              T_d(l) = 0.0
              alpha_d(l) = 0.0
           ENDDO

           rout = r_d(k)
           irout = k

           return
        ENDIF

        ! If disc has disappeared, mark the outer edge and exit the routine
        IF(sigma_d(k) ==0.0) THEN
           !print*, 'Model disc empty!'
           DO l=k,nrannuli
              sigma_d(l) = 0.0
              nu_d(l) = 0.0
              T_d(l) = 0.0
              alpha_d(l) = 0.0
           ENDDO

           rout = r_d(k)
           irout = k
           return
        ENDIF

     ENDDO

     ! If not at beginning of file, interpolations must be 2D (generally)
  ELSE

     ! Now do 2D interpolations

    !print*, 'Interpolating in 2D'
     DO k=1,nrannuli

        rad = r_d(k)
        rout = rad
        irout = k
        j=1
        DO WHILE(r_mod(i,j) < rad .and. j<nrad_mod)
           j=j+1
        ENDDO

        ! If at the very start of interpolation in space, interpolate against zero

        IF(j==1) THEN

           ! Sigma
           CALL interpolate_2D(rad,t_interp,sigma_d(k),0.0,0.0 &
                ,sigma_mod(i-1,j), sigma_mod(i,j),0.0,r_mod(i,j), begintime,finishtime)
           ! Nu
           CALL interpolate_2D(rad,t_interp,nu_d(k),0.0,0.0 &
                ,nu_mod(i-1,j), nu_mod(i,j),0.0,r_mod(i,j), begintime,finishtime)
           ! T
           CALL interpolate_2D(rad,t_interp,T_d(k),0.0,0.0 &
                ,Tc_mod(i-1,j), Tc_mod(i,j),0.0,r_mod(i,j), begintime,finishtime)
           ! Alpha
           CALL interpolate_2D(rad,t_interp,alpha_d(k),0.0,0.0 &
                ,alpha_mod(i-1,j), alpha_mod(i,j),0.0,r_mod(i,j), begintime,finishtime)
           ! Tau
           CALL interpolate_2D(rad,t_interp,tau_d(k),0.0,0.0 &
                ,tau_mod(i-1,j), tau_mod(i,j),0.0,r_mod(i,j), begintime,finishtime)

           ! Otherwise interpolate as normal
        ELSE

           ! Sigma
           CALL interpolate_2D(rad,t_interp,sigma_d(k),sigma_mod(i-1,j-1),sigma_mod(i,j-1) &
                ,sigma_mod(i-1,j), sigma_mod(i,j),r_mod(i,j-1),r_mod(i,j), begintime,finishtime)

           ! Nu
           CALL interpolate_2D(rad,t_interp,nu_d(k),nu_mod(i-1,j-1),nu_mod(i,j-1) &
                ,nu_mod(i-1,j), nu_mod(i,j),r_mod(i,j-1),r_mod(i,j), begintime,finishtime)

           ! T
           CALL interpolate_2D(rad,t_interp,T_d(k),Tc_mod(i-1,j-1),Tc_mod(i,j-1) &
                ,Tc_mod(i-1,j), Tc_mod(i,j),r_mod(i,j-1),r_mod(i,j), begintime,finishtime)

           ! Alpha
           CALL interpolate_2D(rad,t_interp,alpha_d(k),alpha_mod(i-1,j-1),alpha_mod(i,j-1) &
                ,alpha_mod(i-1,j), alpha_mod(i,j),r_mod(i,j-1),r_mod(i,j), begintime,finishtime)

           ! Tau
           CALL interpolate_2D(rad,t_interp,tau_d(k),tau_mod(i-1,j-1),tau_mod(i,j-1) &
                ,tau_mod(i-1,j), tau_mod(i,j),r_mod(i,j-1),r_mod(i,j), begintime,finishtime)
        ENDIF

        !write(74,*) r_d(k)/udist,sigma_d(k)

        mdisc = mdisc + twopi*r_d(k)*sigma_d(k)*dr
        !write(77,*), r_d(k)/udist,sigma_d(k), mdisc/umass

   !  If the maximum model disc radius is reached, record and exit the routine

        IF(j>nrad_mod) THEN
           !print*, 'Maximum model radius reached'
           DO l=k,nrannuli
              sigma_d(l) = 0.0
              nu_d(l) = 0.0
              T_d(l) = 0.0
              alpha_d(l) = 0.0
           ENDDO

           rout = r_d(k)
           irout = k

           return
        ENDIF

        ! If disc has disappeared, mark the outer edge and exit the routine
        IF(sigma_d(k) ==0.0) THEN
           !print*, 'Model disc empty!'
           DO l=k,nrannuli
              sigma_d(l) = 0.0
              nu_d(l) = 0.0
              T_d(l) = 0.0
              alpha_d(l) = 0.0
           ENDDO

           rout = r_d(k)
           irout = k
           return
        ENDIF

     ENDDO
  ENDIF

END SUBROUTINE evolve_disc


!> \brief implements all routines and functions related with tails for hopping
!> integrals and repulsive potentials
!> \author Cristian G. Sanchez and Alin M Elena (Queen's University Belfast)
!> date 1st of November 2007
module m_TailFunctions
  use m_Constants
  use m_Types
  use m_Useful
  implicit none
  private
!
  public :: makeTailType
  public :: tailFunction
  public :: TailFunctionP
  public :: TailFunctionPp
!
contains
!> \brief returns  tailType
!> given the cutoffs and values of the function
!> derivatives at the inner cutoff
!>\details the expression of the tail function \f[
!>          t(r)=(r-r_{cut})^3(10c+5br+3ar^2+5br_{cut}+4arr_{cut}+3ar_{cut}^2)/60
!>          \f] with \f$ a,b,c\f$ given by
!> \f[
!>a=\frac{10}{(r_1-r_{cut})^5}(12A-6Br_1+Cr_1^2+6Br_{cut}-2Cr_1r_{cut}+Cr_{cut}^2)
!>\f]
!>\f[
!> b=-\frac{4}{(r_1-r_{cut})^5}(45Ar_1-21Br_1^2+3Cr_1^3+15Ar_{cut}+12Br_1r_{cut}-4Cr_1^2r_{cut}+
!> 9Br_{cut}^2-Cr_1r_{cut}^2+2Cr_{cut}^3)
!>\f]
!>\f[
!>c=-\frac{1}{(r_1-r_{cut})^5}(-60Ar_1^2+24Br_1^3-3Cr_1^4-60Ar_1r_{cut}+12Br_1^2r_{cut}-
!>36Br_1r_{cut}^2+8Cr_1^2r_{cut}^2-4Cr_1r_{cut}^3-Cr_{cut}^4)
!>\f] with \f$A=f(r_1)\f$, \f$B=f^{\prime}(r_1)\f$, \f$C=f^{\prime\prime}(r_1)\f$ \f$f(r)\f$ is the function that we tail
!> \f$ r_1\f$, \f$ r_{cut} \f$ inner and outer cuttoff
!> \author Cristian G. Sanchez
!> \date ~2004-2005
!> \param f,fp,fpp reals the function and its derivatives at inner cuttoff
!> \param rIn,rOut reals inner and outer cuttoff
!> \param io type(ioType) i/o units
  function makeTailType (f, fp, fpp, rIn, rOut, io)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'makeTailType'
!--subroutine parameters -------------------------!
    type (tailType) :: makeTailType
    real (k_pr) :: f, fp, fpp
    real (k_pr) :: rIn, rOut
    real (k_pr) :: x, x2, a, b, c
    type (ioType), intent (inout) :: io
!--internal variables ----------------------------!
    logical :: status
    character (len=k_ml) :: saux
!-------------------------------------------------!
!
    makeTailType%rIn = rIn
!
    x = rIn
    x2 = rOut
    a = (10*(12*f-6*fp*x+fpp*x**2+6*fp*x2-2*fpp*x*x2+fpp*x2**2)) / (x-x2) ** 5
    b = (-4*(45*f*x-21*fp*x**2+3*fpp*x**3+15*f*x2+12*fp*x*x2-4*fpp*x**2*x2+9*fp*x2**2-fpp*x*x2**2+2*fpp*x2**3)) / (x-x2) ** 5
    c = - &
   & ((-60*f*x**2+24*fp*x**3-3*fpp*x**4-60*f*x*x2+12*fp*x**2*x2-36*fp*x*x2**2+8*fpp*x**2*x2**2-4*fpp*x*x2**3-fpp*x2**4)/(x-x2)**5)
!
    status = CheckTailParam (f, fp, fpp, x, x2)
    if ( .not. status) then
      write (saux, '(a,f0.8,1x,f0.8)') "Second derivative of tail function has solution in ri,rcut region, you should increase rcut&
     &", x, x2
      call error (trim(saux), myname, .false., io)
    end if
    makeTailType%a = a
    makeTailType%b = b
    makeTailType%c = c
    makeTailType%rOut = x2
!
  end function makeTailType
!
!> \brief checks the tail parameters,
!> \details to see wether there is an inflexion point in the
!> tail region causing a maximum in the force
!> \author Alin M. Elena,Queen's University Belfast, UK
!> \date 11th of February, 2005
!> \param f,fp,fpp reals the function and its derivatives at inner cuttoff
!> \param ri,rc reals inner and outer cuttoff
!
  function CheckTailParam (f, fp, fpp, ri, rc)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'CheckTailParam'
!--subroutine parameters -------------------------!
    logical :: CheckTailParam
    real (k_pr) :: f, fp, fpp
    real (k_pr) :: ri, rc
!--internal variables ----------------------------!
    real (k_pr) :: aux1, aux2, x1, x2, sw, aux3
!-------------------------------------------------!
!
    aux2 = 2.0_k_pr * (-120.0_k_pr*f-60.0_k_pr*fp*rc-10.0_k_pr*fpp*rc**2+60.0_k_pr*fp*ri+20.0_k_pr*fpp*rc*ri-10.0_k_pr*fpp*ri**2)
!
    aux1 = (60.0_k_pr*f*rc+36.0_k_pr*fp*rc**2+8.0_k_pr*fpp*rc**3+180.0_k_pr*f*ri+48.0_k_pr*fp*rc*ri-4.0_k_pr*fpp*rc**2*ri-&
   & 84.0_k_pr*fp*ri**2-16.0_k_pr*fpp*rc*ri**2+12.0_k_pr*fpp*ri**3) ** 2 - 4.0_k_pr * (-120.0_k_pr*f-60.0_k_pr*fp*rc-&
   & 10.0_k_pr*fpp*rc**2+60.0_k_pr*fp*ri+20.0_k_pr*fpp*rc*ri-10.0_k_pr*fpp*ri**2) * (-(fpp*rc**4)-60.0_k_pr*f*rc*ri-&
   & 36.0_k_pr*fp*rc**2*ri-4.0_k_pr*fpp*rc**3*ri-60.0_k_pr*f*ri**2+12.0_k_pr*fp*rc*ri**2+8.0_k_pr*fpp*rc**2*ri**2+&
   & 24.0_k_pr*fp*ri**3-3.0_k_pr*fpp*ri**4)
!
    aux3 = - 60.0_k_pr * f * rc - 36.0_k_pr * fp * rc ** 2 - 8.0_k_pr * fpp * rc ** 3 - 180.0_k_pr * f * ri - 48.0_k_pr * fp * rc * &
   & ri + 4.0_k_pr * fpp * rc ** 2 * ri + 84.0_k_pr * fp * ri ** 2 + 16.0_k_pr * fpp * rc * ri ** 2 - 12.0_k_pr * fpp * ri ** 3
!
    if (aux1 < 0.0_k_pr) then
      CheckTailParam = .true.
    else if (Abs(aux2) < epsilon(aux2)) then
      CheckTailParam = .true.
    else
      x1 = (aux3+Sqrt(aux1)) / aux2
      x2 = (aux3-Sqrt(aux1)) / aux2
!
      if (x1 > x2) then
        sw = x1
        x1 = x2
        x2 = sw
      end if
!
      if ((ri > x1) .and. (rc > x2)) then
        CheckTailParam = .true.
      else if (ri < x2) then
        CheckTailParam = .true.
      else
        if (rc < x1) then
          CheckTailParam = .true.
        else
          CheckTailParam = .false.
        end if
      end if
    end if
!
  end function CheckTailParam
!
!
!>\brief returns the value of the tail
!> function at r, given the parameters in tailp
!>\author Cristian G. Sanchez
!> \date ~2004-2005
!> \param r real the point where the function is evaluated
!> \param tailp the tail parameters
  function tailFunction (r, tailp)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'tailFunction'
!--subroutine parameters -------------------------!
    real (k_pr) :: tailFunction
    type (tailType) :: tailp
    real (k_pr) :: r
!--internal variables ----------------------------!
!-------------------------------------------------!
!
    tailFunction = ((r-tailp%rOut)**3*(10*tailp%c+5*tailp%b*r+3*tailp%a*r**2+5*tailp%b*tailp%rOut+4*tailp%a*r*tailp%rOut+&
   & 3*tailp%a*tailp%rOut**2)) / 60.0_k_pr
!
  end function tailFunction
!
!
!> \brief returns a the value of the tail function first derivative at r
!> \author Cristian G. Sanchez
!> \date ~2004-2005
!> \param r real the point where the function is evaluated
!> \param tailp the tail parameters
  function TailFunctionP (r, tailp)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'TailFunctionP'
!--subroutine parameters -------------------------!
    real (k_pr) :: TailFunctionP
    type (tailType) :: tailp
    real (k_pr) :: r
!--internal variables ----------------------------!
!-------------------------------------------------!
!
    TailFunctionP = &
   & ((r-tailp%rOut)**2*(6*tailp%c+4*tailp%b*r+3*tailp%a*r**2+2*tailp%b*tailp%rOut+2*tailp%a*r*tailp%rOut+tailp%a*tailp%rOut**2)) / &
   & 12.0_k_pr
!
  end function TailFunctionP
!
!> \brief returns a the value of the tail function second derivative at r
!> \author Cristian G. Sanchez
!> \date ~2004-2005
!> \param r real the point where the function is evaluated
!> \param tailp the tail parameters
  function TailFunctionPp (r, tailp)
!--subroutine name--------------------------------!
    character (len=*), parameter :: myname = 'TailFunctionPp'
!--subroutine parameters -------------------------!
    real (k_pr) :: TailFunctionPp
    type (tailType) :: tailp
    real (k_pr) :: r
!--internal variables ----------------------------!
!-------------------------------------------------!
!
    TailFunctionPp = (tailp%c+tailp%b*r+tailp%a*r*r) * (r-tailp%rOut)
!
  end function TailFunctionPp
!
end module m_TailFunctions


	SUBROUTINE ludcmp(a,indx,d)
	USE nrtype; USE nrutil, ONLY : assert_eq,imaxloc,nrerror,outerprod,swap
	IMPLICIT NONE
	REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
	INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
	REAL(SP), INTENT(OUT) :: d
	REAL(SP), DIMENSION(size(a,1)) :: vv
	REAL(SP), PARAMETER :: TINY=1.0e-20_sp
	INTEGER(I4B) :: j,n,imax
	n=assert_eq(size(a,1),size(a,2),size(indx),'ludcmp')
	d=1.0
	vv=maxval(abs(a),dim=2)
	if (any(vv == 0.0)) call nrerror('singular matrix in ludcmp')
	vv=1.0_sp/vv

	do j=1,n
		imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j)))
		if (j /= imax) then
			call swap(a(imax,:),a(j,:))
			d=-d
			vv(imax)=vv(j)
		end if
		indx(j)=imax
		if (a(j,j) == 0.0) a(j,j)=TINY
		a(j+1:n,j)=a(j+1:n,j)/a(j,j)
		a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))
	end do
	END SUBROUTINE ludcmp


!     Wrapper for the COULFG.

      subroutine myCOULFG(angL,eta,rho,myf,mydf,myg,mydg,iv)
      double precision  angL,eta, rho, myf, mydf,myg,mydg
      integer iv,lmax
      double precision XLMIN, XLMAX
      double precision XX, ETA1
      integer  MODE1, KFN, IFAIL
      double precision , allocatable, dimension(:):: FC,GC,FCP,GCP
Cf2py intent(in) angL
Cf2py intent(in) eta
Cf2py intent(in) rho
Cf2py intent(out) myf
Cf2py intent(out) mydf
Cf2py intent(out) myg
Cf2py intent(out) mydg
Cf2py intent(out) iv
      XLMIN=angL
      XLMAX=angL
      lmax=IDINT(XLMAX)+1
      allocate (FC(lmax),GC(lmax),FCP(lmax),GCP(lmax))
      MODE1=1
      KFN=0
      XX=rho
      ETA1=eta
      call COULFG(XX,ETA1,XLMIN,XLMAX,FC,GC,FCP,GCP,MODE1,KFN,IFAIL)
      myf=FC(lmax)
      mydf=FCP(lmax)
      myg=GC(lmax)
      mydg=GCP(lmax)
      iv=IFAIL
      return
      end

      SUBROUTINE COULFG(XX,ETA1,XLMIN,XLMAX,FC,GC,FCP,GCP,MODE1,
     & KFN,IFAIL)
C  REVISED #5 IJT WITH L-T ALGORITHMN FOR CONTINUED FRACTIONS,
C  AND IFAIL > 0 FOR AVOIDED EXPONENT CHECKS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C  REVISED COULOMB WAVEFUNCTION PROGRAM USING STEED'S METHOD           C
C                                                                      C
C  A. R. BARNETT           MANCHESTER  MARCH   1981                    C
C                                                                      C
C  ORIGINAL PROGRAM 'RCWFN'      IN    CPC  8 (1974) 377-395           C
C                 + 'RCWFF'      IN    CPC 11 (1976) 141-142           C
C  FULL DESCRIPTION OF ALGORITHM IN    CPC 21 (1981) 297-314           C
C  THIS VERSION WRITTEN UP       IN    CPC 27 (1982) 147-166           C
C                                                                      C
C  COULFG RETURNS F,G,F',G', FOR REAL XX.GT.0,REAL ETA1 (INCLUDING 0), C
C   AND REAL LAMBDA(XLMIN) .GT. -1 FOR INTEGER-SPACED LAMBDA VALUES    C
C   THUS GIVING POSITIVE-ENERGY SOLUTIONS TO THE COULOMB SCHRODINGER   C
C   EQUATION,TO THE KLEIN-GORDON EQUATION AND TO SUITABLE FORMS OF     C
C   THE DIRAC EQUATION ,ALSO SPHERICAL & CYLINDRICAL BESSEL EQUATIONS  C
C                                                                      C
C  FOR A RANGE OF LAMBDA VALUES (XLMAX - XLMIN) MUST BE AN INTEGER,    C
C  STARTING ARRAY ELEMENT IS M1 = MAX0(IDINT(XLMIN+ACCUR),0) + 1       C
C      SEE TEXT FOR MODIFICATIONS FOR INTEGER L-VALUES                 C
C                                                                      C
C  IF 'MODE' = 1  GET F,G,F',G'   FOR INTEGER-SPACED LAMBDA VALUES     C
C            = 2      F,G      UNUSED ARRAYS MUST BE DIMENSIONED IN    C
C            = 3      F               CALL TO AT LEAST LENGTH (1)      C
C  IF 'KFN'  = 0 REAL        COULOMB FUNCTIONS ARE RETURNED            C
C            = 1 SPHERICAL   BESSEL      "      "     "                C
C            = 2 CYLINDRICAL BESSEL      "      "     "                C
C  THE USE OF 'MODE' AND 'KFN' IS INDEPENDENT                          C
C                                                                      C
C  PRECISION:  RESULTS TO WITHIN 2-3 DECIMALS OF 'MACHINE ACCURACY'    C
C   IN OSCILLATING REGION X .GE. ETA1 + SQRT(ETA1**2 + XLM(XLM+1))     C
C   COULFG IS CODED FOR REAL*8 ON IBM OR EQUIVALENT  ACCUR = 10**-16   C
C   USE AUTODBL + EXTENDED PRECISION ON HX COMPILER  ACCUR = 10**-33   C
C   FOR MANTISSAS OF 56 & 112 BITS. FOR SINGLE PRECISION CDC (48 BITS) C
C   REASSIGN DSQRT=SQRT ETC.  SEE TEXT FOR COMPLEX ARITHMETIC VERSION  C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT double precision (A-H,O-Z)
      DIMENSION    FC(*),GC(*),FCP(*),GCP(*)
      LOGICAL      ETANE0,XLTURN
      COMMON       /STEE / PACCQ,NFP,NPQ,IEXP,M1
C***  COMMON BLOCK IS FOR INFORMATION ONLY.  NOT REQUIRED IN CODE
C***  COULFG HAS CALLS TO: DSQRT,DABS,DMOD,IDINT,DSIGN,DFLOAT,DMIN1
      DATA ZERO,ONE,TWO,TEN2,ABORT /0.0D0, 1.0D0, 2.0D0, 1.0D2, 2.0D4/
      DATA HALF,TM30,BIG / 0.5D0, 1.0D-30, 1.0D+100/
      DATA RT2DPI /0.79788 45608 02865 35587 98921 19868 76373 D0/
C *** THIS CONSTANT IS  DSQRT(TWO/PI):  USE Q0 FOR IBM REAL*16: D0 FOR
C ***  REAL*8 & CDC DOUBLE P:  E0 FOR CDC SINGLE P; AND TRUNCATE VALUE.
C
      ACCUR = 1.0D-16
C ***            CHANGE ACCUR TO SUIT MACHINE AND PRECISION REQUIRED
!      write(*,*) XLMIN,XLMAX
      MODE  = 1
      IF(MODE1 .EQ. 2 .OR. MODE1 .EQ. 3 ) MODE = MODE1
      IFAIL = 0
      IEXP  = 1
      NPQ   = 0
      ETA   = ETA1
      GJWKB = ZERO
      PACCQ = ONE
      IF(KFN .NE. 0) ETA = ZERO
                 ETANE0  = ETA .NE. ZERO
      ACC   = ACCUR * 10D0
      ACC4  = ACC*TEN2*TEN2
      ACCH  = DSQRT(ACC)
C ***    TEST RANGE OF XX, EXIT IF.LE.DSQRT(ACCUR) OR IF NEGATIVE
C
      IF(XX .LE. ACCH)                          GO TO 100
      X     = XX
      XLM   = XLMIN
      IF(KFN .EQ. 2)  XLM = XLM - HALF
      IF(XLM .LE. -ONE .OR. XLMAX .LT. XLMIN)   GO TO 105
      E2MM1 = ETA*ETA + XLM*XLM + XLM
      XLTURN= X*(X - TWO*ETA) .LT. XLM*XLM + XLM
      DELL  = XLMAX - XLMIN + ACC
      IF(DABS(DMOD(DELL,ONE)) .GT. 2*ACC) WRITE(6,2040)XLMAX,XLMIN,DELL
      LXTRA = IDINT(DELL)
      XLL   = XLM + DFLOAT(LXTRA)
C ***       LXTRA IS NUMBER OF ADDITIONAL LAMBDA VALUES TO BE COMPUTED
C ***       XLL  IS MAX LAMBDA VALUE, OR 0.5 SMALLER FOR J,Y BESSELS
C ***         DETERMINE STARTING ARRAY ELEMENT (M1) FROM XLMIN
      M1  = MAX0(IDINT(XLMIN + ACC),0) + 1
      L1  = M1 + LXTRA
C
C ***    EVALUATE CF1  =  F   =  FPRIME(XL,ETA,X)/F(XL,ETA,X)
C
      XI  = ONE/X
      FCL = ONE
      PK  = XLL + ONE
      PX  = PK  + ABORT
      F   =  ETA/PK + PK*XI
         IF(DABS(F).LT.TM30) F = TM30
         D = ZERO
         C = F
C
C ***   BEGIN CF1 LOOP ON PK = K = LAMBDA + 1
C
    4 PK1   = PK + ONE
        EK  = ETA / PK
        RK2 = ONE + EK*EK
        TK  = (PK + PK1)*(XI + EK/PK1)
        D   =  TK - RK2 * D
        C   =  TK - RK2 / C
         IF(DABS(C).LT.TM30) C = TM30
         IF(DABS(D).LT.TM30) D = TM30
         D = ONE/D
         DF = D * C
         F  = F * DF
            IF(D .LT. ZERO) FCL = - FCL
         PK = PK1
                          IF( PK .GT. PX ) GO TO 110
      IF(DABS(DF-ONE) .GE. ACC)             GO TO 4
                  NFP = PK - XLL - 1
      IF(LXTRA .EQ. 0)                          GO TO 7
C
C *** DOWNWARD RECURRENCE TO LAMBDA = XLM. ARRAY GC,IF PRESENT,STORES RL
C
      FCL = FCL/BIG
      FPL = FCL*F
      IF(MODE .EQ. 1) FCP(L1) = FPL
                      FC (L1) = FCL
      XL  = XLL
      RL  = ONE
      EL  = ZERO
      DO 6  LP = 1,LXTRA
         IF(ETANE0) EL = ETA/XL
         IF(ETANE0) RL = DSQRT(ONE + EL*EL)
         SL    =  EL  + XL*XI
         L     =  L1  - LP
         FCL1  = (FCL *SL + FPL)/RL
         FPL   =  FCL1*SL - FCL *RL
         FCL   =  FCL1
         FC(L) =  FCL
         IF(MODE .EQ. 1) FCP(L)  = FPL
         IF(MODE .NE. 3 .AND. ETANE0) GC(L+1) = RL
	 if(abs(FCL).gt.BIG) then
		do 55 LP1=L,M1+LXTRA
      		IF(MODE .EQ. 1) FCP(LP1) = FCP(LP1)*1d-20
 55                    		FC (LP1) = FC(LP1)*1d-20
		FCL=FC(L)
		FPL=FPL*1d-20
		endif
    6 XL = XL - ONE
      IF(FCL .EQ. ZERO) FCL = ACC
      F  = FPL/FCL
C ***    NOW WE HAVE REACHED LAMBDA = XLMIN = XLM
C ***    EVALUATE CF2 = P + I.Q  AGAIN USING STEED'S ALGORITHM
C ***    SEE TEXT FOR COMPACT COMPLEX CODE FOR SP CDC OR NON-ANSI IBM
C
    7 IF( XLTURN ) CALL JWKB(X,ETA,DMAX1(XLM,ZERO),FJWKB,GJWKB,IEXP)
      IF( IEXP .GT. 1 .OR. GJWKB .GT. ONE/(ACCH*TEN2))  GO TO 9
          XLTURN = .FALSE.
      TA =  TWO*ABORT
      PK =  ZERO
      WI =  ETA + ETA
      P  =  ZERO
      Q  =  ONE - ETA*XI
      AR = -E2MM1
      AI =  ETA
      BR =  TWO*(X - ETA)
      BI =  TWO
      DR =  BR/(BR*BR + BI*BI)
      DI = -BI/(BR*BR + BI*BI)
      DP = -XI*(AR*DI + AI*DR)
      DQ =  XI*(AR*DR - AI*DI)
    8 P     = P  + DP
         Q  = Q  + DQ
         PK = PK + TWO
         AR = AR + PK
         AI = AI + WI
         BI = BI + TWO
         D  = AR*DR - AI*DI + BR
         DI = AI*DR + AR*DI + BI
         C  = ONE/(D*D + DI*DI)
         DR =  C*D
         DI = -C*DI
         A  = BR*DR - BI*DI - ONE
         B  = BI*DR + BR*DI
         C  = DP*A  - DQ*B
         DQ = DP*B  + DQ*A
         DP = C
         IF(PK .GT. TA)                         GO TO 120
      IF(DABS(DP)+DABS(DQ).GE.(DABS(P)+DABS(Q))*ACC)   GO TO 8
                      NPQ   = PK/TWO
                      PACCQ = HALF*ACC/DMIN1(DABS(Q),ONE)
                      IF(DABS(P) .GT. DABS(Q)) PACCQ = PACCQ*DABS(P)
C
C *** SOLVE FOR FCM = F AT LAMBDA = XLM,THEN FIND NORM FACTOR W=W/FCM
C
      GAM = (F - P)/Q
            IF(Q .LE. ACC4*DABS(P))             GO TO 130
      W   = ONE/DSQRT((F - P)*GAM + Q)
            GO TO 10
C *** ARRIVE HERE IF G(XLM) .GT. 10**6 OR IEXP .GT. 70 & XLTURN = .TRUE.
    9 W   = FJWKB
      GAM = GJWKB*W
      P   = F
      Q   = ONE
C
C *** NORMALISE FOR SPHERICAL OR CYLINDRICAL BESSEL FUNCTIONS
C
   10                     ALPHA = ZERO
          IF(KFN  .EQ. 1) ALPHA = XI
          IF(KFN  .EQ. 2) ALPHA = XI*HALF
                          BETA  = ONE
          IF(KFN  .EQ. 1) BETA  = XI
          IF(KFN  .EQ. 2) BETA  = DSQRT(XI)*RT2DPI
      FCM  = DSIGN(W,FCL)*BETA
           FC(M1)  = FCM
                      IF(MODE .EQ. 3)           GO TO 11
           IF(.NOT. XLTURN)   GCL =  FCM*GAM
           IF(      XLTURN)   GCL =  GJWKB*BETA
           IF( KFN .NE. 0 )   GCL = -GCL
           GC(M1)  = GCL
           GPL =  GCL*(P - Q/GAM) - ALPHA*GCL
                      IF(MODE .EQ. 2)           GO TO 11
           GCP(M1) = GPL
           FCP(M1) = FCM*(F - ALPHA)
   11 IF(LXTRA .EQ. 0 ) RETURN
C *** UPWARD RECURRENCE FROM GC(M1),GCP(M1)  STORED VALUE IS RL
C *** RENORMALISE FC,FCP AT EACH LAMBDA AND CORRECT REGULAR DERIVATIVE
C ***    XL   = XLM HERE  AND RL = ONE , EL = ZERO FOR BESSELS
         W    = BETA*W/DABS(FCL)
         MAXL = L1 - 1
      DO 12 L = M1,MAXL
                      IF(MODE .EQ. 3)           GO TO 12
                      XL = XL + ONE
         IF(ETANE0)   EL = ETA/XL
         IF(ETANE0)   RL = GC(L+1)
                      SL = EL + XL*XI
         GCL1     = ((SL - ALPHA)*GCL - GPL)/RL
		IF(ABS(GCL1).gt.BIG) GO TO 140
         GPL      =   RL*GCL -  (SL + ALPHA)*GCL1
         GCL      = GCL1
         GC(L+1)  = GCL1
                      IF(MODE .EQ. 2)           GO TO 12
         GCP(L+1) = GPL
         FCP(L+1) = W*(FCP(L+1) - ALPHA*FC(L+1))
   12 FC(L+1)     = W* FC(L+1)
      RETURN
C
C ***    ERROR MESSAGES
C
  100 IFAIL = -1
      WRITE(6,2000) XX,ACCH
 2000 FORMAT(' FOR XX = ',1P,D12.3,' TRY SMALL-X  SOLUTIONS',
     *' OR X NEGATIVE'/ ,' SQUARE ROOT ACCURACY PARAMETER =  ',D12.3/)
      RETURN
  105 IFAIL = -2
      WRITE (6,2005) XLMAX,XLMIN,XLM
 2005 FORMAT(/' PROBLEM WITH INPUT ORDER VALUES:XLMAX,XLMIN,XLM = ',
     *1P,3D15.6/)
      RETURN
  110 IFAIL = -3
      WRITE (6,2010) ABORT,F ,DF,PK,PX,ACC
 2010 FORMAT(' CF1 HAS FAILED TO CONVERGE AFTER ',F10.0,' ITERATIONS',/
     *' F,DF,PK,PX,ACCUR =  ',1P,5D12.3//)
      RETURN
  120 IFAIL = -4
      WRITE (6,2020) ABORT,P,Q,DP,DQ,ACC
 2020 FORMAT(' CF2 HAS FAILED TO CONVERGE AFTER ',F7.0,' ITERATIONS',/
     *' P,Q,DP,DQ,ACCUR =  ',1P,4D17.7,D12.3//)
      RETURN
  130 IFAIL = -5
      WRITE (6,2030) P,Q,ACC,DELL,LXTRA,M1
 2030 FORMAT(' FINAL Q.LE.DABS(P)*ACC*10**4 , P,Q,ACC = ',1P,3D12.3,4X,
     *' DELL,LXTRA,M1 = ',D12.3,2I5 /)
      RETURN
 2040 FORMAT(' XLMAX - XLMIN = DELL NOT AN INTEGER ',1P,3D20.10/)
  140 IFAIL=L1-L
      RETURN
      END
C
      SUBROUTINE JWKB(XX,ETA1,XL,FJWKB,GJWKB,IEXP)                      ABNK0331
      implicit double precision(a-h,o-z)
c     REAL*8          XX,ETA1,XL,FJWKB,GJWKB,DZERO                      ABNK0332
C *** COMPUTES JWKB APPROXIMATIONS TO COULOMB FUNCTIONS    FOR XL.GE. 0 ABNK0333
C *** AS MODIFIED BY BIEDENHARN ET AL. PHYS REV 97 (1955) 542-554       ABNK0334
C *** CALLS DMAX1,SQRT,ALOG,EXP,ATAN2,FLOAT,INT        BARNETT FEB 1981 ABNK0335
      DATA   ZERO,HALF,ONE,SIX,TEN/ 0, 0.5d0, 1, 6, 10 /                ABNK0336
c     DATA  DZERO, RL35, ALOGE  /0,35, 0.43429 45 E0 /                  ABNK0337
      DATA  DZERO, RL35 /0,35 /                                         ABNK0337
      aloge=log(ten)
      X     = XX                                                        ABNK0339
      ETA   = ETA1                                                      ABNK0339
      GH2   = X*(ETA + ETA - X)                                         ABNK0340
      XLL1  = MAX(XL*XL + XL,DZERO)                                     ABNK0341
      IF(GH2 + XLL1 .LE. ZERO) RETURN                                   ABNK0342
       HLL  = XLL1 + SIX/RL35                                           ABNK0343
       HL   = SQRT(HLL)                                                 ABNK0344
       SL   = ETA/HL + HL/X                                             ABNK0345
       RL2  = ONE + ETA*ETA/HLL                                         ABNK0346
       GH   = SQRT(GH2 + HLL)/X                                         ABNK0347
       PHI  = X*GH - HALF*( HL*LOG((GH + SL)**2/RL2) - LOG(GH) )        ABNK0348
          IF(ETA .NE. ZERO) PHI = PHI - ETA*ATAN2(X*GH,X - ETA)         ABNK0349
      PHI10 = -PHI*ALOGE                                                ABNK0350
      IEXP  =  INT(PHI10)                                               ABNK0351
      IF(IEXP .GT. 70) GJWKB = TEN**(PHI10 - IEXP)                      ABNK0352
      IF(IEXP .LE. 70) GJWKB = EXP(-PHI)                                ABNK0353
      IF(IEXP .LE. 70) IEXP  = 0                                        ABNK0354
      FJWKB = HALF/(GH*GJWKB)                                           ABNK0355
      RETURN                                                            ABNK0356
      END                                                               ABNK0357

      SUBROUTINE WHIT(HETA,R,XK,E,LL,F,FD,IE)
C
C     CALCULATES  WHITTAKER  FUNCTION  WL(K,R)  WITH
C     ASYMPTOTIC  FORM  EXP(-(KR + ETA(LOG(2KR)))
C     E  IS  NEGATIVE
C     If IE = 0, allowed to return result e**IE larger than Whittaker,
C                for the IE value returned.
C     If IE > 0, must scale results by that amount.
C
C     Author: I.J. Thompson, downloaded from http://www.fresco.org.uk
      IMPLICIT double precision  (A-H,O-Z)
      DIMENSION F(LL+1),FD(LL+1) ,T(12),S(7)
      data fpmax/1.0d290/
      L = LL+1
C              NOW L = NO. OF VALUES TO FIND
      EE=-1.0
      AK=XK
      ETA=HETA
      LP1=L+1
      RHO=AK*R
	S(:) = 0
      IF(L-50)1,1,2
    1 LM=60
      GO TO 3
    2 LM=L+10
    3 LMP1=LM+1
      IS=7
      PJE=30.0*RHO+1.0
      H=max(INT(PJE),4)
      H=RHO/H
!	write(147,111) R,RHO,H
!111	format(3f10.6)
      RHOA=10.0*(ETA+1.0)
      IF(RHOA-RHO)13,13,14
   13 IFEQL=1
      RHOA=RHO
      GO TO 15
   14 IFEQL=0
   15 PJE=RHOA/H+0.5
      RHOA=H*INT(PJE)
      IF(IFEQL)16,16,18
   16 IF(RHOA-RHO-1.5*H)17,18,18
   17 RHOA=RHO+2.0*H
   18 IF(EE)55,55,19
   19 STOP 'WHIT'
   27 A=2.0-10.0/12.0*H*H*EE
      B=1.0/6.0*H*ETA
      C=1.0+1.0/12.0*H*H*EE
      M1=INT(RHOA/H-0.5)
      M2=INT(RHO/H-1.5)
      T(2)=B/FLOAT(M1+1)
      T(3)=B/FLOAT(M1)
      JS=M1
      DO 29 IS=M2,M1
      DO 28 I=1,6
      S(I)=S(I+1)
   28 CONTINUE
      T(1)=T(2)
      T(2)=T(3)
      T(3)=B/FLOAT(JS-1)
      S(7)=((A+10.0*T(2))*S(6)-(C-T(1))*S(5))/(C-T(3))
      JS=JS-1
      IF(ABS(S(7)).LE.FPMAX) GO TO 29
       DO 285 I=2,7
  285   S(I) = S(I) / FPMAX
   29 CONTINUE
      T(1)=S(4)
      T(2)=(1.0/60.0*(S(1)-S(7))+0.15*(S(6)-S(2))+0.75*(S(3)-S(5)))/H
      GO TO 60
   55 C=1.0/RHOA
      A=1.0
      B=1.0-C*ETA
      F(1)=A
      FD(1)=B
      DO 56 M=1,26
      D=0.5*(ETA+FLOAT(M-1))*(ETA+FLOAT(M))*C/FLOAT(M)
      A=-A*D
      B=-B*D-A*C
      F(1)=F(1)+A
      FD(1)=FD(1)+B
   56 CONTINUE
      A=-ETA*LOG(2.0*RHOA)-RHOA
      FPMINL = -LOG(FPMAX)
      if(IE.eq.0.and.A.LT.FPMINL) IE = INT(FPMINL-A)
      A=EXP(A+IE)
      F(1)=A*F(1)
c      FD(1)=A*FD(1)
      FD(1)=A*FD(1) * (-1d0 - 2*ETA/(RHOA))
      IF(IFEQL)57,57,61
   57 S(IS)=F(1)
      IF(IS-7)27,58,27
   58 IS=6
      RHOA=RHOA+H
      GO TO 55
   60 F(1)=T(1)
      FD(1)=T(2)
   61 C=1.0/RHO
      DO 63 M=1,L-1
      A=ETA/FLOAT(M)
      B=A+C*FLOAT(M)
      F(M+1)=(B*F(M)-FD(M))/(A+1.0)
      FD(M+1)=(A-1.0)*F(M)-B*F(M+1)
   63 CONTINUE
      DO 65 M=1,L
      FD(M)=AK*FD(M)
   65 CONTINUE
      RETURN
      END