module kernel_utils_mod

use globals_mod
use equations_mod, only: N_VARS

private

public :: kernel_utils_init
public :: interpolate2visual

!! -------------------------------------------------------------------------- !!
!! nodes within reference element [-1,1]

real(dp), save, public :: refnodes(N_NODES)
real(dp), save, public :: refweights(N_NODES)
real(dp), save, public :: refweights2D(N_NODES,N_NODES)

!! ------------------------------------------------------------------------- !!
!! Weak-Form Standard DG operators (on Legendre-Gauss nodes)

real(dp), save, public :: diffMat(N_NODES,N_NODES)

real(dp), save, public :: surfMat(N_NODES,N_NODES)
real(dp), save, public :: surfTam(N_NODES,N_NODES)

!! ------------------------------------------------------------------------- !!
!! Visualization operator

real(dp), save :: visuMat(N_NODES,N_NODES)
real(dp), save :: visuTam(N_NODES,N_NODES)

contains

!! ========================================================================== !!
!! Routines regarding Lagrange polynomials as well as quadrature points generation

pure function lagrange_polynomial(N, nodes, j, x) result(lp)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    integer, intent(in)     :: j
    real(dp), intent(in)    :: x

    real(dp)                :: lp

    integer :: i

    lp = 1.0

    if (abs(x-nodes(j)) < 10*TOL) return !! Kronecker property

    do i = 1,N
        if (i == j) cycle
        lp = lp * (x - nodes(i))/(nodes(j) - nodes(i))
    end do

end function

pure function lagrange_basis(N, nodes, x) result(lp)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: x

    real(dp)                :: lp(N)
    integer :: i

    !! Kronecker property
    if (any(abs(x-nodes) < 10*TOL)) then
        lp = merge(1.0,0.0,abs(x-nodes) < 10*TOL)
        return
    end if

    forall (i = 1:N) lp(i) = Lagrange_Polynomial(N, nodes, i, x)

end function

pure subroutine lagrange_VanderMonde_Matrix(N, M, xs, ys, mat)

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: xs(N), ys(M)
    real(dp), intent(out)   :: mat(M,N)

    integer :: i

    do i = 1,M
        mat(i,:) = Lagrange_Basis(N, xs, ys(i))
    end do

end subroutine

subroutine barycentric_weights(N,nodes,weights)

    integer,intent(in)      :: N
    real(dp),intent(in)     :: nodes(N)
    real(dp),intent(out)    :: weights(N)

    integer :: i,j

    weights = 1.0_dp

    do i = 2,N
        do j = 1,i-1
            weights(j) = weights(j)*(nodes(j) - nodes(i))
            weights(i) = weights(i)*(nodes(i) - nodes(j))
        end do
    end do

    weights = 1.0_dp/weights

end subroutine

subroutine lagrange_diff_matrix(N,nodes,diffMat)

    integer,intent(in)      :: N !! number of nodes
    real(dp),intent(in)     :: nodes(N)
    real(dp),intent(out)    :: diffMat(N,N)

    integer     :: i,j
    real(dp)    :: bweights(N)

    call barycentric_weights(N,nodes,bweights)

    diffMat = 0.0_dp

    do j = 1,N
        do i = 1,N
            if (i.ne.j) then
                diffMat(i,j) = bweights(j)/(bweights(i)*(nodes(i) - nodes(j)))
                diffMat(i,i) = diffMat(i,i) - diffMat(i,j)
            end if
        end do
    end do

end subroutine

pure subroutine q_and_L_evaluation(p,x,q,dq,L_N)

    integer, intent(in)     :: p !! polynomial order
    real(dp), intent(in)    :: x
    real(dp), intent(out)   :: L_n,q,dq

    integer     :: k
    real(dp)    :: L_n_1,L_n_2,L_k,dL_n,dL_n_1,dL_n_2,dL_k

    L_N_2   = 1.0_dp
    L_N_1   = x
    dL_N_2  = 0.0_dp
    dL_N_1  = 1.0_dp

    do k = 2,p
        L_N     = (2.0_dp*real(k,dp) - 1.0_dp)/real(k,dp)*x*L_N_1 - (real(k,dp)-1.0_dp)/real(k,dp)*L_N_2
        dL_N    = dL_N_2 + (2.0_dp*real(k,dp) - 1.0_dp) * L_N_1
        L_N_2   = L_N_1
        L_N_1   = L_N
        dL_N_2  = dL_N_1
        dL_N_1  = dL_N
    end do

    !! take another step
    k       = p+1
    L_k     = (2.0_dp*real(k,dp) - 1.0_dp)/real(k,dp)*x*L_N - (real(k,dp) - 1.0_dp)/real(k,dp)*L_N_2
    dL_k    = dL_N_2 + (2.0_dp*real(k,dp) - 1.0_dp) * L_N_1
    q       = L_k - L_N_2
    dq      = dL_k - dL_N_2

end subroutine

pure subroutine equidistant_nodes_and_weights(N,nodes,weights)

    integer,intent(in)              :: N
    real(dp),intent(out)            :: nodes(N)
    real(dp),intent(out),optional   :: weights(N)

    integer :: i

    do i = 1,N
        nodes(i) = -1.0 + 2.0*(real(i,dp)-0.5)/real(N,dp)
    end do

    weights = 2.0/real(N,dp)

end subroutine

pure subroutine Legendre_Gauss_Lobatto_Nodes_And_Weights(N,nodes,weights)

    integer, intent(in)     :: N !! number of nodes
    real(dp), intent(out)   :: nodes(N)
    real(dp), intent(out)   :: weights(N)

    integer, parameter      :: niter = 10
    real(dp)                :: q,dq,L_n,delta

    integer                 :: i,j

    nodes(1)    = -1.0_dp
    weights(1)  =  2.0_dp / (real(N-1,dp)*real(N,dp))

    nodes(N)    = -nodes(1)
    weights(N)  = weights(1)

    if (N < 3) return

    do i = 2,N/2
        !! initial guess
        nodes(i) = -cos(((real(i-1,dp)+0.25_dp)*pi)/real(N-1,dp) - (3.0_dp/(8.0_dp*real(N-1,dp)*pi)) * (1.0_dp/(real(i-1,dp)+0.25_dp)))

        !! Newton iteration
        do j = 1,niter
            call q_And_L_Evaluation(N-1,nodes(i),q,dq,L_N)

            delta = q/dq
            nodes(i) = nodes(i) - delta

            if (abs(delta) < 10*tol*abs(nodes(i))) exit
        end do

        call q_And_L_Evaluation(N-1,nodes(i),q,dq,L_N)

        weights(i) = 2.0_dp / (real(N-1,dp)*real(N,dp) * L_N*L_N)

        nodes(N+1-i)    = -nodes(i)
        weights(N+1-i)  = weights(i)
    end do

    if (mod(N+1,2) == 0) then
        call q_And_L_Evaluation(N-1,0.0_dp,q,dq,L_N)

        nodes(N/2+1)    = 0.0_dp
        weights(N/2+1)  = 2.0_dp / (real(N-1,dp) * real(N,dp) * L_N*L_N)
    end if

end subroutine

!! ========================================================================== !!
!! public routines

subroutine kernel_utils_init()

    integer, parameter :: N = N_NODES

    real(dp) :: fvnodes(N_NODES), fvweights(N_NODES)
    real(dp) :: dgnodes(N_NODES), dgweights(N_NODES)

    integer :: i,j

    call Equidistant_Nodes_And_Weights(N_NODES,fvnodes,fvweights)

    !! This implementation of the 'strong form' only valid for Gauss-Lobatto nodes!
    call Legendre_Gauss_Lobatto_Nodes_And_Weights(N_NODES,dgnodes,dgweights)

    !! --------------------------------------------------------------------- !!
    !! Surface Term Matrix (also called Stiffness Matrix)

    surfMat(:,:) =  0.0_dp
    surfMat(1,1) =  2.0_dp/dgweights(1)
    surfMat(N,N) = -2.0_dp/dgweights(N)
    surfTam = transpose(surfMat)

    !! --------------------------------------------------------------------- !!
    !! Volume Term Matrix (flux differencing form)

    call lagrange_Diff_Matrix(N_NODES,dgnodes,diffMat)
    diffMat = 4.0_dp*diffMat + surfMat

    !! --------------------------------------------------------------------- !!
    !! Visualization Matrix

    call lagrange_VanderMonde_Matrix(N_NODES,N_NODES,dgnodes,fvnodes,visuMat)
    visuTam = transpose(visuMat)

    !! --------------------------------------------------------------------- !!

    refnodes = dgnodes
    refweights = dgweights

    !! Scaled it to unity.
    do j = 1,N_NODES; do i = 1,N_NODES
        refweights2D(i,j) = 0.25*refweights(i)*refweights(j)
    end do; end do

    !! --------------------------------------------------------------------- !!

# if 0
    write (*,*) 'fvnodes', fvnodes
    write (*,*) 'dgnodes', dgnodes
    write (*,*) 'dgweights', dgweights
    write (*,*)

    write (*,*) 'toBoundaryVec{M,P}'
    write (*,'(32(ES12.4))') toBoundaryVecM
    write (*,'(32(ES12.4))') toBoundaryVecP
    write (*,*)

    write (*,*) 'diffMat'
    do i = 1,N_NODES
        write (*,'(32(ES12.4))') diffMat(i,:)
    end do
    write (*,*)

    write (*,*) 'surfMat'
    do i = 1,N_NODES
        write (*,'(32(ES12.4))') surfmat(i,:)
    end do
    write (*,*)
# endif

end subroutine

pure subroutine interpolate2visual(input,output)

    real(dp), intent(in) :: input(N_NODES,N_NODES)
    real(dp), intent(out) :: output(N_NODES,N_NODES)

    output = matmul(visuMat,matmul(input,visuTam))

end subroutine

end module


module mod_union_find
  implicit none
  type union_find
    integer :: n
    integer, pointer :: par(:), rnk(:), siz(:)
  end type union_find
  private
  public :: union_find
  public :: init_union_find, release_union_find, find, same, unite, size_of
contains
  subroutine init_union_find(uf,n)
    implicit none
    type(union_find), intent(inout) :: uf
    integer, intent(in) :: n
    integer :: i
    uf%n = n
    allocate(uf%par(n),uf%rnk(n),uf%siz(n))
    uf%rnk = 0
    uf%siz = 1
    do i = 1, n
      uf%par(i) = i
    end do
    return
  end subroutine init_union_find
  subroutine release_union_find(uf)
    implicit none
    type(union_find), intent(inout) :: uf
    if (associated(uf%par)) deallocate(uf%par)
    if (associated(uf%rnk)) deallocate(uf%rnk)
    if (associated(uf%siz)) deallocate(uf%siz)
    return
  end subroutine release_union_find
  recursive function find(uf,i) result(j)
    implicit none
    type(union_find), intent(inout) :: uf
    integer, intent(in) :: i
    integer :: j
    if (uf%par(i).ne.i) then
      uf%par(i) = find(uf,uf%par(i))
    end if
    j = uf%par(i)
    return
  end function find
  function same(uf,i,j) result(y)
    implicit none
    type(union_find), intent(inout) :: uf
    integer, intent(in) :: i, j
    logical :: y
    y = find(uf,i).eq.find(uf,j)
  end function same
  subroutine unite(uf,i,j)
    implicit none
    type(union_find), intent(inout) :: uf
    integer, intent(in) :: i, j
    integer :: x, y
    x = find(uf,i)
    y = find(uf,j)
    if (x.eq.y) return
    if (uf%rnk(x).lt.uf%rnk(y)) then
      uf%par(x) = y
      uf%siz(y) = uf%siz(y)+uf%siz(x)
    else
      uf%par(y) = x
      uf%siz(x) = uf%siz(x)+uf%siz(y)
      if (uf%rnk(x).eq.uf%rnk(y)) uf%rnk(x) = uf%rnk(x)+1
    end if
    return
  end subroutine unite
  function size_of(uf,i) result(s)
    implicit none
    type(union_find), intent(inout) :: uf
    integer, intent(in) :: i
    integer :: s
    s = uf%siz(find(uf,i))
  end function size_of
end module mod_union_find


module interpolation

public :: spline
public :: spline_interpolation

!==================================================================================================!
contains
!==================================================================================================!

subroutine spline(x,y,n,yp1,ypn,y2)
!----
! (From Press et al., Numerical Recipes)
!
! Given arrays x(1:n) and y(1:n) containing a tabulated function, i.e., yi = f(xi),
! with x1 < x2 < ... < xN, and given values yp1 and ypn for the first derivative of the
! interpolating function at points 1 and n, respectively, this routine returns an
! array y2(1:n) of length n which contains the second derivatives of the interpolating
! function at the tabulated points xi. If yp1 and/or ypn are equal to 1 × 10^30 or larger,
! the routine is signaled to set the corresponding boundary condition for a natural spline,
! with zero second derivative on that boundary.
!
! Parameter: NMAX is the largest anticipated value of n.
!----

implicit none

! Arguments
integer :: n
double precision :: yp1, ypn, x(n), y(n), y2(n)

! Local variables
integer, parameter :: nmax = 500
integer :: i, k
double precision :: p, qn, sig, un, u(nmax)

! Set the lower boundary condition to be natural or specified first derivative
if (abs(yp1).ge.1.0d30) then
    y2(1) = 0.0d0
    u(1) = 0.0d0
else
    y2(1) = -0.5d0
    u(1) = (3.0d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
endif

! Tridiagonal algorithm
do i = 2,n-1
    sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
    p = sig*y2(i-1)+2.0d0
    y2(i) = (sig-1.0d0)/p
    u(i) = (6.0d0*( &
               (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

! Set the upper boundary condition to be natural or specified first derivative
if (abs(ypn).gt.1.0d30) then
    qn = 0.0d0
    un = 0.0d0
else
    qn = 0.5d0
    un = (3.0d0/(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.0d0)

! Back-substitution of the tridiagonal algorithm
do k = n-1,1,-1
    y2(k) = y2(k)*y2(k+1)+u(k)
enddo

return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine spline_interpolation(xa,ya,y2a,n,x,y,dy,d2y)
!----
! (From Press et al., Numerical Recipes)
!
! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function (with the xai’s in
! order), and given the array y2a(1:n), which is the output from spline above, and given a value
! of x, this routine returns a cubic-spline interpolated value y.
!----

implicit none

! Arguments
integer :: n
double precision :: x, y, dy, d2y, xa(n), y2a(n), ya(n)

! Local variables
integer :: k, khi, klo
double precision :: a, b, h

klo = 1
khi = n

! We will find the right place in the table by means of bisection. This is optimal if sequential
! calls to this routine are at random values of x. If sequential calls are in order, and closely
! spaced, one would do better to store previous values of klo and khi and test if they remain
! appropriate on the next call.

! khi and klo bracket the input value of x
do while (khi-klo.gt.1)
    k = (khi+klo)/2
    if (xa(k).gt.x) then
        khi = k
    else
        klo = k
    endif
enddo

h = xa(khi)-xa(klo)

! The xa's must be distinct
if (abs(h).lt.1.0d-10) then
    write(0,*) 'spline_interpolation: bad xa input'
endif

! Evaluate cubic spline polynomial value, derivative, and second derivative
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.0d0
dy = (ya(khi)-ya(klo))/(xa(khi)-xa(klo)) - &
     (3.0d0*a**2-1.0d0)*(xa(khi)-xa(klo))*y2a(klo)/6.0d0 + &
     (3.0d0*b**2-1.0d0)*(xa(khi)-xa(klo))*y2a(khi)/6.0d0
d2y = a*y2a(klo) + b*y2a(khi)

return
end subroutine

end module


subroutine spline (n, x, y, b, c, d)
  integer n
  real(kind=8) ::x(n), y(n), b(n), c(n), d(n)
!
!  the coefficients b(i), c(i), and d(i), i=1,2,...,n are computed
!  for a cubic interpolating spline
!
!    s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
!
!    for  x(i) .le. x .le. x(i+1)
!
!  input..
!
!    n = the number of data points or knots (n.ge.2)
!    x = the abscissas of the knots in strictly increasing order
!    y = the ordinates of the knots
!
!  output..
!
!    b, c, d  = arrays of spline coefficients as defined above.
!
!  using  p  to denote differentiation,
!
!    y(i) = s(x(i))
!    b(i) = sp(x(i))
!    c(i) = spp(x(i))/2
!    d(i) = sppp(x(i))/6  (derivative from the right)
!
!  the accompanying function subprogram  seval  can be used
!  to evaluate the spline.
!
!
  integer nm1, ib, i
  real(kind=8) ::t

  nm1 = n-1
  if (n < 2) then
    return
  elseif ( n == 2 ) then
    b(1) = (y(2)-y(1))/(x(2)-x(1))
    c(1) = 0.
    d(1) = 0.
    b(2) = b(1)
    c(2) = 0.
    d(2) = 0.
    return
  else

!
!  set up tridiagonal system
!
!  b = diagonal, d = offdiagonal, c = right hand side.
!
    d(1) = x(2) - x(1)
    c(2) = (y(2) - y(1))/d(1)
    do i = 2, nm1
      d(i) = x(i+1) - x(i)
      b(i) = 2.*(d(i-1) + d(i))
      c(i+1) = (y(i+1) - y(i))/d(i)
      c(i) = c(i+1) - c(i)
    enddo
!
!  end conditions.  third derivatives at  x(1)  and  x(n)
!  obtained from divided differences
!
    b(1) = -d(1)
    b(n) = -d(n-1)
    c(1) = 0.
    c(n) = 0.
    if ( n /= 3 ) then
      c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
      c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
      c(1) = c(1)*d(1)**2/(x(4)-x(1))
      c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
    endif
!
!  forward elimination
!
    do i = 2, n
      t = d(i-1)/b(i-1)
      b(i) = b(i) - t*d(i-1)
      c(i) = c(i) - t*c(i-1)
    enddo
!
!  back substitution
!
    c(n) = c(n)/b(n)
    do ib = 1, nm1
      i = n-ib
      c(i) = (c(i) - d(i)*c(i+1))/b(i)
    enddo
!
!  c(i) is now the sigma(i) of the text
!
!  compute polynomial coefficients
!
    b(n) = (y(n) - y(nm1))/d(nm1) + d(nm1)*(c(nm1) + 2.*c(n))
    do i = 1, nm1
      b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.*c(i))
      d(i) = (c(i+1) - c(i))/d(i)
      c(i) = 3.*c(i)
    enddo
    c(n) = 3.*c(n)
    d(n) = d(n-1)
    return
  endif

end subroutine spline

real(kind=8) function seval(n, u, x, y, b, c, d)

  implicit none
  integer n
  real(kind=8) :: u, x(n), y(n), b(n), c(n), d(n)
!
!  this subroutine evaluates the cubic spline function
!
!    seval = y(i) + b(i)*(u-x(i)) + c(i)*(u-x(i))**2 + d(i)*(u-x(i))**3
!
!    where  x(i) .lt. u .lt. x(i+1), using horner's rule
!
!  if  u .lt. x(1) then  i = 1  is used.
!  if  u .ge. x(n) then  i = n  is used.
!
!  input..
!
!    n = the number of data points
!    u = the abscissa at which the spline is to be evaluated
!    x,y = the arrays of data abscissas and ordinates
!    b,c,d = arrays of spline coefficients computed by spline
!
!  if  u  is not in the same interval as the previous call, then a
!  binary search is performed to determine the proper interval.
!
  integer i, j, k
  real(kind=8) ::dx
  data i/1/
  if ( i >= n ) i = 1
  if ( u < x(i) ) go to 10
  if ( u <= x(i+1) ) go to 30
!
!  binary search
!
 10 i = 1
  j = n+1
 20 k = (i+j)/2
  if ( u < x(k) ) j = k
  if ( u >= x(k) ) i = k
  if ( j > i+1 ) go to 20
!
!  evaluate spline
!
 30 dx = u - x(i)
  seval = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
  return

end function seval


subroutine calc_bpf_order(fl, fh, fs, ap, as, sample, m, n, c)
  use constants, only : pi
  implicit none
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!! Butterworth band-pass filter by Saito(1978)
  !!! fl: low frequency cut-off (Hz) not normalized
  !!! fh: high frequency cut-off (Hz) not normalized
  !!! fs: stopped frequency (Hz) not normalized
  !!! Ap: maximum attenuation in fp (usually 0.5)
  !!! As: minimum attenuation in fs (usually 5.0)
  !!! sample: sampling interval (sec)
  !!! m: order of filter
  !!! n: order of butterworth function
  !!! c: filter coefficient
  !!!
  !!! Usage:
  !!! 1. call calc_bpf_order(fl, fh, fs, ap, as, sample, m, n, c)
  !!! 2. allocate filter coefficient allocate(h(4 * m))
  !!! 3. call calc_bpf_coef(fl, fh, sample, m, n, h, c, gn)
  !!! 4. call tandem(data, data, ndata, h, m, nml)
  !!!
  !!! Author   : Masashi Ogiso (masashi.ogiso@gmail.com)
  !!! Reference: Saito, M. (1978) An automatic design algorithm for band selective recursive
  !!!                             digital filters, Geophysical Exploration, 31(4), 240-263 (In Japanese)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  real*8, intent(IN) :: fl,fh, fs, ap, as, sample
  integer, intent(OUT) :: m, n
  real*8, intent(OUT) :: c

  real*8 :: sigma_fl, sigma_fh, sigma_fs, op, os

  sigma_fl = pi * fl * sample
  sigma_fh = pi * fh * sample
  sigma_fs = abs(fs * sample) * pi

  op = sin(sigma_fh - sigma_fl) / (cos(sigma_fl) * cos(sigma_fh))
  os = abs(tan(sigma_fs) - tan(sigma_fh) * tan(sigma_fl) / tan(sigma_fs))

  n = max(2, ifix(abs(real(log(as / ap) / log(op / os))) + 0.5))
  m = n
  c = sqrt(exp(log(ap * as) / dble(n)) / (op * os))

  return
end subroutine calc_bpf_order


C
C     file hw3crt.f
C
      SUBROUTINE HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS,
     1                   BDYF,ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,
     2                   MDIMF,F,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDXS(MDIMF,N+1),    BDXF(MDIMF,N+1),
C ARGUMENTS              BDYS(LDIMF,N+1),    BDYF(LDIMF,N+1),
C                        BDZS(LDIMF,M+1),    BDZF(LDIMF,M+1),
C                        F(LDIMF,MDIMF,N+1), W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION TO THE HELMHOLTZ
C                        EQUATION IN CARTESIAN COORDINATES.  THIS
C                        EQUATION IS
C
C                          (D/DX)(DU/DX) + (D/DY)(DU/DY) +
C                          (D/DZ)(DU/DZ) + LAMBDA*U = F(X,Y,Z) .
C
C USAGE                  CALL HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,
C                                     MBDCND,BDYS,BDYF,ZS,ZF,N,NBDCND,
C                                     BDZS,BDZF,ELMBDA,LDIMF,MDIMF,F,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C
C ON INPUT               XS,XF
C
C                          THE RANGE OF X, I.E. XS .LE. X .LE. XF .
C                          XS MUST BE LESS THAN XF.
C
C                        L
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (XS,XF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE L+1 GRID POINTS
C                          IN THE X-DIRECTION GIVEN BY
C                          X(I) = XS+(I-1)DX FOR I=1,2,...,L+1,
C                          WHERE DX = (XF-XS)/L IS THE PANEL WIDTH.
C                          L MUST BE AT LEAST 5.
C
C                        LBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT X = XS AND X = XF.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN X,
C                               I.E. U(L+I,J,K) = U(I,J,K).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               X = XS AND X = XF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               X = XS AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO X IS
C                               SPECIFIED AT X = XF.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED AT
C                               X = XS AND X = XF.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED AT
C                               X = XS AND THE SOLUTION IS SPECIFIED
C                               AT X=XF.
C
C                        BDXS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE DERIVATIVE OF THE SOLUTION
C                          WITH RESPECT TO X AT X = XS.
C
C                          WHEN LBDCND = 3 OR 4,
C
C                            BDXS(J,K) = (D/DX)U(XS,Y(J),Z(K)),
C                            J=1,2,...,M+1,      K=1,2,...,N+1.
C
C                          WHEN LBDCND HAS ANY OTHER VALUE, BDXS
C                          IS A DUMMY VARIABLE. BDXS MUST BE
C                          DIMENSIONED AT LEAST (M+1)*(N+1).
C
C                        BDXF
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE DERIVATIVE OF THE SOLUTION
C                          WITH RESPECT TO X AT X = XF.
C
C                          WHEN LBDCND = 2 OR 3,
C
C                            BDXF(J,K) = (D/DX)U(XF,Y(J),Z(K)),
C                            J=1,2,...,M+1,      K=1,2,...,N+1.
C
C                          WHEN LBDCND HAS ANY OTHER VALUE, BDXF IS
C                          A DUMMY VARIABLE.  BDXF MUST BE
C                          DIMENSIONED AT LEAST (M+1)*(N+1).
C
C                        YS,YF
C                          THE RANGE OF Y, I.E. YS .LE. Y .LE. YF.
C                          YS MUST BE LESS THAN YF.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (YS,YF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE M+1 GRID POINTS IN
C                          THE Y-DIRECTION GIVEN BY Y(J) = YS+(J-1)DY
C                          FOR J=1,2,...,M+1,
C                          WHERE DY = (YF-YS)/M IS THE PANEL WIDTH.
C                          M MUST BE AT LEAST 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT Y = YS AND Y = YF.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E.
C                               U(I,M+J,K) = U(I,J,K).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               Y = YS AND Y = YF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               Y = YS AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO Y IS
C                               SPECIFIED AT Y = YF.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = YS AND Y = YF.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               AT Y = YS AND THE SOLUTION IS
C                               SPECIFIED AT Y=YF.
C
C                        BDYS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE DERIVATIVE OF THE
C                          SOLUTION WITH RESPECT TO Y AT Y = YS.
C
C                          WHEN MBDCND = 3 OR 4,
C
C                            BDYS(I,K) = (D/DY)U(X(I),YS,Z(K)),
C                            I=1,2,...,L+1,      K=1,2,...,N+1.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDYS
C                          IS A DUMMY VARIABLE. BDYS MUST BE
C                          DIMENSIONED AT LEAST (L+1)*(N+1).
C
C                        BDYF
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE DERIVATIVE OF THE
C                          SOLUTION WITH RESPECT TO Y AT Y = YF.
C
C                          WHEN MBDCND = 2 OR 3,
C
C                            BDYF(I,K) = (D/DY)U(X(I),YF,Z(K)),
C                            I=1,2,...,L+1,      K=1,2,...,N+1.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDYF
C                          IS A DUMMY VARIABLE. BDYF MUST BE
C                          DIMENSIONED AT LEAST (L+1)*(N+1).
C
C                        ZS,ZF
C                          THE RANGE OF Z, I.E. ZS .LE. Z .LE. ZF.
C                          ZS MUST BE LESS THAN ZF.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (ZS,ZF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE N+1 GRID POINTS
C                          IN THE Z-DIRECTION GIVEN BY
C                          Z(K) = ZS+(K-1)DZ FOR K=1,2,...,N+1,
C                          WHERE DZ = (ZF-ZS)/N IS THE PANEL WIDTH.
C                          N MUST BE AT LEAST 5.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT Z = ZS AND Z = ZF.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Z, I.E.
C                               U(I,J,N+K) = U(I,J,K).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               Z = ZS AND Z = ZF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               Z = ZS AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO Z IS
C                               SPECIFIED AT Z = ZF.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Z IS SPECIFIED AT
C                               Z = ZS AND Z = ZF.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Z IS SPECIFIED AT
C                               Z = ZS AND THE SOLUTION IS SPECIFIED
C                               AT Z=ZF.
C
C                        BDZS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE DERIVATIVE OF THE
C                          SOLUTION WITH RESPECT TO Z AT Z = ZS.
C
C                          WHEN NBDCND = 3 OR 4,
C
C                            BDZS(I,J) = (D/DZ)U(X(I),Y(J),ZS),
C                            I=1,2,...,L+1,      J=1,2,...,M+1.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDZS
C                          IS A DUMMY VARIABLE. BDZS MUST BE
C                          DIMENSIONED AT LEAST (L+1)*(M+1).
C
C                        BDZF
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE DERIVATIVE OF THE
C                          SOLUTION WITH RESPECT TO Z AT Z = ZF.
C
C                          WHEN NBDCND = 2 OR 3,
C
C                            BDZF(I,J) = (D/DZ)U(X(I),Y(J),ZF),
C                            I=1,2,...,L+1,      J=1,2,...,M+1.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDZF
C                          IS A DUMMY VARIABLE. BDZF MUST BE
C                          DIMENSIONED AT LEAST (L+1)*(M+1).
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION. IF LAMBDA .GT. 0, A SOLUTION
C                          MAY NOT EXIST.  HOWEVER, HW3CRT WILL
C                          ATTEMPT TO FIND A SOLUTION.
C
C                        LDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE
C                          ARRAYS F,BDYS,BDYF,BDZS,AND BDZF AS IT
C                          APPEARS IN THE PROGRAM CALLING HW3CRT.
C                          THIS PARAMETER IS USED TO SPECIFY THE
C                          VARIABLE DIMENSION OF THESE ARRAYS.
C                          LDIMF MUST BE AT LEAST L+1.
C
C                        MDIMF
C                          THE COLUMN (OR SECOND) DIMENSION OF THE
C                          ARRAY F AND THE ROW (OR FIRST) DIMENSION
C                          OF THE ARRAYS BDXS AND BDXF AS IT APPEARS
C                          IN THE PROGRAM CALLING HW3CRT.  THIS
C                          PARAMETER IS USED TO SPECIFY THE VARIABLE
C                          DIMENSION OF THESE ARRAYS.
C                          MDIMF MUST BE AT LEAST M+1.
C
C                        F
C                          A THREE-DIMENSIONAL ARRAY OF DIMENSION AT
C                          AT LEAST (L+1)*(M+1)*(N+1), SPECIFYING THE
C                          VALUES OF THE RIGHT SIDE OF THE HELMHOLZ
C                          EQUATION AND BOUNDARY VALUES (IF ANY).
C
C                          ON THE INTERIOR, F IS DEFINED AS FOLLOWS:
C                          FOR I=2,3,...,L,  J=2,3,...,M,
C                          AND K=2,3,...,N
C                          F(I,J,K) = F(X(I),Y(J),Z(K)).
C
C                          ON THE BOUNDARIES, F IS DEFINED AS FOLLOWS:
C                          FOR J=1,2,...,M+1,  K=1,2,...,N+1,
C                          AND I=1,2,...,L+1
C
C                          LBDCND      F(1,J,K)         F(L+1,J,K)
C                          ------   ---------------   ---------------
C
C                            0      F(XS,Y(J),Z(K))   F(XS,Y(J),Z(K))
C                            1      U(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C                            2      U(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))
C                            3      F(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))
C                            4      F(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C
C                          MBDCND      F(I,1,K)         F(I,M+1,K)
C                          ------   ---------------   ---------------
C
C                            0      F(X(I),YS,Z(K))   F(X(I),YS,Z(K))
C                            1      U(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C                            2      U(X(I),YS,Z(K))   F(X(I),YF,Z(K))
C                            3      F(X(I),YS,Z(K))   F(X(I),YF,Z(K))
C                            4      F(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C
C                          NBDCND      F(I,J,1)         F(I,J,N+1)
C                          ------   ---------------   ---------------
C
C                            0      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZS)
C                            1      U(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C                            2      U(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)
C                            3      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)
C                            4      F(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION
C                          U AND THE RIGHT SIDE F ON A BOUNDARY,
C                          THEN THE SOLUTION MUST BE SPECIFIED.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          THE LENGTH OF W MUST BE AT LEAST
C                          30 + L + M + 5*N + MAX(L,M,N) +
C                          7*(INT((L+1)/2) + INT((M+1)/2))
C
C
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J,K) OF THE
C                          FINITE DIFFERENCE APPROXIMATION FOR THE
C                          GRID POINT (X(I),Y(J),Z(K)) FOR
C                          I=1,2,...,L+1, J=1,2,...,M+1,
C                          AND K=1,2,...,N+1.
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS IS SPECIFIED FOR A
C                          POISSON EQUATION (LAMBDA = 0), A SOLUTION
C                          MAY NOT EXIST.  PERTRB IS A CONSTANT,
C                          CALCULATED AND SUBTRACTED FROM F, WHICH
C                          ENSURES THAT A SOLUTION EXISTS.  PWSCRT
C                          THEN COMPUTES THIS SOLUTION, WHICH IS A
C                          LEAST SQUARES SOLUTION TO THE ORIGINAL
C                          APPROXIMATION.  THIS SOLUTION IS NOT
C                          UNIQUE AND IS UNNORMALIZED.  THE VALUE OF
C                          PERTRB SHOULD BE SMALL COMPARED TO THE
C                          THE RIGHT SIDE F.  OTHERWISE, A SOLUTION
C                          IS OBTAINED TO AN ESSENTIALLY DIFFERENT
C                          PROBLEM.  THIS COMPARISON SHOULD ALWAYS
C                          BE MADE TO INSURE THAT A MEANINGFUL
C                          SOLUTION HAS BEEN OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 12,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR
C                          =  1  XS .GE. XF
C                          =  2  L .LT. 5
C                          =  3  LBDCND .LT. 0 .OR. LBDCND .GT. 4
C                          =  4  YS .GE. YF
C                          =  5  M .LT. 5
C                          =  6  MBDCND .LT. 0 .OR. MBDCND .GT. 4
C                          =  7  ZS .GE. ZF
C                          =  8  N .LT. 5
C                          =  9  NBDCND .LT. 0 .OR. NBDCND .GT. 4
C                          = 10  LDIMF .LT. L+1
C                          = 11  MDIMF .LT. M+1
C                          = 12  LAMBDA .GT. 0
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HW3CRT, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       POIS3D, FFTPACK, AND COMF FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE DEFINES THE FINITE DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                        ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS AND
C                        THEN CALLS POIS3D TO SOLVE THE SYSTEM.
C
C TIMING                 FOR LARGE L, M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          L*M*N*(LOG2(L)+LOG2(M)+5),
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS LBDCND
C                        AND MBDCND.
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN
C                        A LOSS OF NO MORE THAN FOUR SIGNIFICANT
C                        DIGITS FOR L, M AND N AS LARGE AS 32.
C                        MORE DETAILED INFORMATION ABOUT ACCURACY
C                        CAN BE FOUND IN THE DOCUMENTATION FOR
C                        ROUTINE POIS3D WHICH IS THE ROUTINE THAT
C                        ACTUALLY SOLVES THE FINITE DIFFERENCE
C                        EQUATIONS.
C
C REFERENCES             NONE
C***********************************************************************
      DIMENSION       BDXS(MDIMF,*)          ,BDXF(MDIMF,*)          ,
     1                BDYS(LDIMF,*)          ,BDYF(LDIMF,*)          ,
     2                BDZS(LDIMF,*)          ,BDZF(LDIMF,*)          ,
     3                F(LDIMF,MDIMF,*)       ,W(*)
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (XF .LE. XS) IERROR = 1
      IF (L .LT. 5) IERROR = 2
      IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3
      IF (YF .LE. YS) IERROR = 4
      IF (M .LT. 5) IERROR = 5
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6
      IF (ZF .LE. ZS) IERROR = 7
      IF (N .LT. 5) IERROR = 8
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9
      IF (LDIMF .LT. L+1) IERROR = 10
      IF (MDIMF .LT. M+1) IERROR = 11
      IF (IERROR .NE. 0) GO TO 188
      DY = (YF-YS)/FLOAT(M)
      TWBYDY = 2./DY
      C2 = 1./(DY**2)
      MSTART = 1
      MSTOP = M
      MP1 = M+1
      MP = MBDCND+1
      GO TO (104,101,101,102,102),MP
  101 MSTART = 2
  102 GO TO (104,104,103,103,104),MP
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      DZ = (ZF-ZS)/FLOAT(N)
      TWBYDZ = 2./DZ
      NP = NBDCND+1
      C3 = 1./(DZ**2)
      NP1 = N+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,105,106,106),NP
  105 NSTART = 2
  106 GO TO (108,108,107,107,108),NP
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
      LP1 = L+1
      DX = (XF-XS)/FLOAT(L)
      C1 = 1./(DX**2)
      TWBYDX = 2./DX
      LP = LBDCND+1
      LSTART = 1
      LSTOP = L
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (122,109,109,112,112),LP
  109 LSTART = 2
      DO 111 J=MSTART,MSTOP
         DO 110 K=NSTART,NSTOP
            F(2,J,K) = F(2,J,K)-C1*F(1,J,K)
  110    CONTINUE
  111 CONTINUE
      GO TO 115
  112 DO 114 J=MSTART,MSTOP
         DO 113 K=NSTART,NSTOP
            F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K)
  113    CONTINUE
  114 CONTINUE
  115 GO TO (122,116,119,119,116),LP
  116 DO 118 J=MSTART,MSTOP
         DO 117 K=NSTART,NSTOP
            F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K)
  117    CONTINUE
  118 CONTINUE
      GO TO 122
  119 LSTOP = LP1
      DO 121 J=MSTART,MSTOP
         DO 120 K=NSTART,NSTOP
            F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K)
  120    CONTINUE
  121 CONTINUE
  122 LUNK = LSTOP-LSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (136,123,123,126,126),MP
  123 DO 125 I=LSTART,LSTOP
         DO 124 K=NSTART,NSTOP
            F(I,2,K) = F(I,2,K)-C2*F(I,1,K)
  124    CONTINUE
  125 CONTINUE
      GO TO 129
  126 DO 128 I=LSTART,LSTOP
         DO 127 K=NSTART,NSTOP
            F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K)
  127    CONTINUE
  128 CONTINUE
  129 GO TO (136,130,133,133,130),MP
  130 DO 132 I=LSTART,LSTOP
         DO 131 K=NSTART,NSTOP
            F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K)
  131    CONTINUE
  132 CONTINUE
      GO TO 136
  133 DO 135 I=LSTART,LSTOP
         DO 134 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K)
  134    CONTINUE
  135 CONTINUE
  136 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
      GO TO (150,137,137,140,140),NP
  137 DO 139 I=LSTART,LSTOP
         DO 138 J=MSTART,MSTOP
            F(I,J,2) = F(I,J,2)-C3*F(I,J,1)
  138    CONTINUE
  139 CONTINUE
      GO TO 143
  140 DO 142 I=LSTART,LSTOP
         DO 141 J=MSTART,MSTOP
            F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J)
  141    CONTINUE
  142 CONTINUE
  143 GO TO (150,144,147,147,144),NP
  144 DO 146 I=LSTART,LSTOP
         DO 145 J=MSTART,MSTOP
            F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1)
  145    CONTINUE
  146 CONTINUE
      GO TO 150
  147 DO 149 I=LSTART,LSTOP
         DO 148 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J)
  148    CONTINUE
  149 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
  150 CONTINUE
      IWB = NUNK+1
      IWC = IWB+NUNK
      IWW = IWC+NUNK
      DO 151 K=1,NUNK
         I = IWC+K-1
         W(K) = C3
         W(I) = C3
         I = IWB+K-1
         W(I) = -2.*C3+ELMBDA
  151 CONTINUE
      GO TO (155,155,153,152,152),NP
  152 W(IWC) = 2.*C3
  153 GO TO (155,155,154,154,155),NP
  154 W(IWB-1) = 2.*C3
  155 CONTINUE
      PERTRB = 0.
C
C     FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST.
C
      GO TO (156,172,172,156,172),LP
  156 GO TO (157,172,172,157,172),MP
  157 GO TO (158,172,172,158,172),NP
  158 IF (ELMBDA) 172,160,159
  159 IERROR = 12
      GO TO 172
  160 CONTINUE
      MSTPM1 = MSTOP-1
      LSTPM1 = LSTOP-1
      NSTPM1 = NSTOP-1
      XLP = (2+LP)/3
      YLP = (2+MP)/3
      ZLP = (2+NP)/3
      S1 = 0.
      DO 164 K=2,NSTPM1
         DO 162 J=2,MSTPM1
            DO 161 I=2,LSTPM1
               S1 = S1+F(I,J,K)
  161       CONTINUE
            S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP
  162    CONTINUE
         S2 = 0.
         DO 163 I=2,LSTPM1
            S2 = S2+F(I,1,K)+F(I,MSTOP,K)
  163    CONTINUE
         S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/
     1                                                          XLP)/YLP
         S1 = S1+S2
  164 CONTINUE
      S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+
     1    F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+
     2                                   F(LSTOP,MSTOP,NSTOP))/(XLP*YLP)
      DO 166 J=2,MSTPM1
         DO 165 I=2,LSTPM1
            S = S+F(I,J,1)+F(I,J,NSTOP)
  165    CONTINUE
  166 CONTINUE
      S2 = 0.
      DO 167 I=2,LSTPM1
         S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP)
  167 CONTINUE
      S = S2/YLP+S
      S2 = 0.
      DO 168 J=2,MSTPM1
         S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP)
  168 CONTINUE
      S = S2/XLP+S
      PERTRB = (S/ZLP+S1)/((FLOAT(LUNK+1)-XLP)*(FLOAT(MUNK+1)-YLP)*
     1                                              (FLOAT(NUNK+1)-ZLP))
      DO 171 I=1,LUNK
         DO 170 J=1,MUNK
            DO 169 K=1,NUNK
               F(I,J,K) = F(I,J,K)-PERTRB
  169       CONTINUE
  170    CONTINUE
  171 CONTINUE
  172 CONTINUE
      NPEROD = 0
      IF (NBDCND .EQ. 0) GO TO 173
      NPEROD = 1
      W(1) = 0.
      W(IWW-1) = 0.
  173 CONTINUE
      CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB),
     1             W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW))
C
C     FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS.
C
      IF (LP .NE. 1) GO TO 180
      IF (MP .NE. 1) GO TO 175
      DO 174 K=NSTART,NSTOP
         F(1,MP1,K) = F(1,1,K)
  174 CONTINUE
      MSTOP = MP1
  175 IF (NP .NE. 1) GO TO 177
      DO 176 J=MSTART,MSTOP
         F(1,J,NP1) = F(1,J,1)
  176 CONTINUE
      NSTOP = NP1
  177 DO 179 J=MSTART,MSTOP
         DO 178 K=NSTART,NSTOP
            F(LP1,J,K) = F(1,J,K)
  178    CONTINUE
  179 CONTINUE
  180 CONTINUE
      IF (MP .NE. 1) GO TO 185
      IF (NP .NE. 1) GO TO 182
      DO 181 I=LSTART,LSTOP
         F(I,1,NP1) = F(I,1,1)
  181 CONTINUE
      NSTOP = NP1
  182 DO 184 I=LSTART,LSTOP
         DO 183 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,1,K)
  183    CONTINUE
  184 CONTINUE
  185 CONTINUE
      IF (NP .NE. 1) GO TO 188
      DO 187 I=LSTART,LSTOP
         DO 186 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,1)
  186    CONTINUE
  187 CONTINUE
  188 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


C     LAST UPDATE 06/09/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION KCOF(R,E,N)
      IMPLICIT NONE
C
C Purpose: Calculates the K coefficients for the Fourier-Bessel
C          interpolation of intensity.
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      REAL TOL
      PARAMETER(TOL=1.0E-06)
C
C Arguments:
C
      REAL R,E
      INTEGER N
C
C Local variables:
C
      REAL DR2
C
C External function:
C
      REAL BESSJ
      EXTERNAL BESSJ
C
C-----------------------------------------------------------------------
      IF(ABS(E-R).GT.TOL)THEN
         DR2 = (E+R)*(E-R)
         KCOF = 2.0*E*BESSJ(2*N,R)/(DR2*BESSJ(2*N+1,E))
      ELSE
         KCOF = 1.0
      ENDIF
      RETURN
      END


! 4670 Numerical Analysis
! Homework Three Due 10/18/17

module secret

integer :: fcounter

end module secret

program WebberHomework3Question1
use secret
implicit none

integer :: i
integer :: n
double precision, allocatable, dimension(:) :: a
double precision, allocatable, dimension(:) :: xdata
double precision, allocatable, dimension(:) :: ydata

n = 4

allocate(xdata(0:n), ydata(0:n), a(0:n))

xdata = (/ 2.0d0, 4.0d0, 6.0d0, 5.0d0, 9.0d0 /)
ydata = (/ 12.0d0, 19.0d0, 14.0d0, 17.0d0, 10.0d0 /)

print*, 'Newtons Divided Difference Coefficients: '

call divdiff(n, xdata, ydata, a)

do i = 0, n
	print*, a(i)
end do

deallocate(xdata, ydata, a)

stop
end program WebberHomework3Question1

subroutine divdiff(n, xdata, ydata, a)

integer :: i
integer :: j
integer :: n
double precision :: a(0:n)
double precision :: xdata(0:n)
double precision :: ydata(0:n)
double precision, allocatable, dimension(:,:) :: T

allocate (T(0:n,0:n))

do i = 0, n
	T(i,0) = ydata(i)
end do

a(0) = ydata(0)

do i = 1, n
	do j = 1, n
		T(i,j) = ((T(i,(j - 1)) - T((i - 1),(j - 1))) / (xdata(i) - xdata(i - j)))
		if (i == j) then
			a(i) = T(i,j)
		end if
	end do
end do

deallocate(T)

end subroutine divdiff


program stencil
    implicit none
    integer, parameter  :: nsources=3
    integer             :: n=2400     ! n x n grid
    integer             :: energy=1   ! energy to be injected per iteration
    integer             :: niters=250 ! number of iterations
    integer             :: iters, i, j, size, sizeStart, sizeEnd
    integer, dimension(3, 2)        :: sources
    double precision, allocatable   :: aold(:,:), anew(:,:)
    double precision    :: t=0.0, t1=0.0, heat=0.0

    call cpu_time(t1)
    t = -t1

    size = n + 2
    sizeStart = 2
    sizeEnd = n + 1

    allocate(aold(size, size))
    allocate(anew(size, size))
    aold = 0.0
    anew = 0.0

    sources(1,:) = (/ n/2,   n/2   /)
    sources(2,:) = (/ n/3,   n/3   /)
    sources(3,:) = (/ n*4/5, n*8/9 /)   ! 8/9 conforme Balaji

    do iters = 1, niters, 2

        ! iteracao impar: anew <- stencil(aold)

        do j = sizeStart, sizeEnd
            do i = sizeStart, sizeEnd
                anew(i,j)=1/2.0*(aold(i,j)+1/4.0*(aold(i-1,j)+aold(i+1,j)+ aold(i,j-1)+aold(i,j+1)))
            enddo
        enddo

        do i = 1, nsources
            anew(sources(i,1)+1, sources(i,2)+1) =  &
                anew(sources(i,1)+1, sources(i,2)+1) + energy
        enddo

        ! iteracao par: aold <- stencil(anew)

        do j = sizeStart, sizeEnd
            do i = sizeStart, sizeEnd
                aold(i,j)=1/2.0*(anew(i,j)+1/4.0*(anew(i-1,j)+anew(i+1,j)+anew(i,j-1)+anew(i,j+1)))
            enddo
        enddo

        do i = 1, nsources
            aold(sources(i,1)+1, sources(i,2)+1) =  &
                aold(sources(i,1)+1, sources(i,2)+1) + energy
        enddo

    enddo

    heat = 0.0
    do j = sizeStart, sizeEnd
        do i = sizeStart, sizeEnd
            heat = heat + aold(i,j)
        end do
    end do

    deallocate(aold)
    deallocate(anew)

    call cpu_time(t1)
    t = t + t1

    write(*, "('Heat = ' f0.4' | ')", advance="no") heat
    write(*, "('Time = 'f0.4)") t

end


C$Procedure  VTMVG  ( Vector transpose times matrix times vector )

      DOUBLE PRECISION FUNCTION VTMVG ( V1, MATRIX, V2, NROW, NCOL )

C$ Abstract
C
C      Multiply the transpose of a n-dimensional column vector,
C      a nxm matrix, and a m-dimensional column vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C      None.
C
C$ Keywords
C
C      MATRIX,  VECTOR
C
C$ Declarations

      INTEGER           NROW
      INTEGER           NCOL
      DOUBLE PRECISION  V1      ( NROW       )
      DOUBLE PRECISION  MATRIX  ( NROW, NCOL )
      DOUBLE PRECISION  V2      (       NCOL )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I   N-dimensional double precision column vector.
C       MATRIX    I   NxM double precision matrix.
C       V2        I   M-dimensional double porecision column vector.
C       NROW      I   Number of rows in MATRIX (number of rows in V1.)
C       NCOL      I   Number of columns in MATRIX (number of rows in
C                     V2.)
C
C       The function returns the result of (V1**T * MATRIX * V2 ).
C
C$ Detailed_Input
C
C      V1         is an n-dimensional double precision vector.
C
C      MATRIX     is an n x m double precision matrix.
C
C      V2         is an m-dimensional double precision vector.
C
C      NROW       is the number of rows in MATRIX.  This is also
C                 equivalent to the number of rows in the vector V1.
C
C      NCOL       is the number of columns in MATRIX. This is also
C                 equivalent to the number of rows in the vector V2.
C
C$ Detailed_Output
C
C      The function returns the double precision value of the equation
C      (V1**T * MATRIX * V2 ).
C
C      Notice that VTMVG is actually the dot product of the vector
C      resulting from multiplying the transpose of V1 and MATRIX and the
C      vector V2.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine implements the following vector/matrix/vector
C      multiplication:
C
C                       T
C         VTMVG = [   V1   ] |          |  |  |
C                            |  MATRIX  |  |V2|
C                            |          |  |  |
C
C      by calculating over all values of the indices K and L from 1 to
C      NROW and 1 to NCOL, respectively, the expression
C
C         VTMVG = Summation of ( V1(K)*MATRIX(K,L)*V2(L) ) .
C
C      V1 is a column vector which becomes a row vector when transposed.
C      V2 is a column vector.
C
C      No checking is performed to determine whether floating point
C      overflow has occurred.
C
C$ Examples
C
C      If  V1 = | 1.0D0 |  MATRIX = | 2.0D0  0.0D0 |  V2 = | 1.0D0 |
C               |       |           |              |       |       |
C               | 2.0D0 |           | 1.0D0  2.0D0 |       | 2.0D0 |
C               |       |           |              |
C               | 3.0D0 |           | 1.0D0  1.0D0 |
C
C      NROW = 3
C      NCOL = 2
C
C      then the value of the function is  21.0D0.
C
C$ Restrictions
C
C      Since no error detection or recovery is implemented, the
C      programmer is required to insure that the inputs to this routine
C      are both valid and within the proper range.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     n-dimensional vector_transpose times matrix times vector
C
C-&

      INTEGER K,L
C
C  Perform the multiplication
C
      VTMVG = 0.D0
      DO K = 1, NROW
         DO L = 1, NCOL
            VTMVG = VTMVG + V1(K)*MATRIX(K,L)*V2(L)
         END DO
      END DO

      RETURN
      END


MODULE length_interval
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: flatten_method
CONTAINS
  FUNCTION flatten_method(first_point_coord, second_point_coord) RESULT(interval)
    IMPLICIT NONE
    REAL, DIMENSION (1:3) :: first_point_coord, second_point_coord
    REAL :: interval
    INTEGER :: i
    interval = 0d0
    DO i = 1, 3
      interval = (first_point_coord(i) - second_point_coord(i)) ** 2 + interval
    END DO
  END FUNCTION flatten_method
END MODULE length_interval

PROGRAM test_length_interval
  USE length_interval
  IMPLICIT NONE
  REAL, DIMENSION (1:3) :: x, y
  PRINT *, 'This program is used to calculated the interval between two points'
  PRINT *,'Input the first vector'
  READ (*,*) x(1),x(2),x(3)
  PRINT *,'Input the second vector'
  READ (*,*) y(1),y(2),y(3)
  PRINT *,'The length interval is :', flatten_method(x,y)
END PROGRAM test_length_interval


PROGRAM meulera

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:11

!       ==========================================================
!       Purpose: This program computes Euler number En using
!                subroutine EULERA
!       Example: Compute Euler number En for n = 0,2,...,10
!                Computed results:

!                   n            En
!                 --------------------------
!                   0     .100000000000D+01
!                   2    -.100000000000D+01
!                   4     .500000000000D+01
!                   6    -.610000000000D+02
!                   8     .138500000000D+04
!                  10    -.505210000000D+05
!       ==========================================================

DOUBLE PRECISION :: e
DIMENSION e(0:200)
WRITE(*,*)'  Please enter Nmax '
!        READ(*,*)N
n=10
CALL eulera(n,e)
WRITE(*,*)'   n            En'
WRITE(*,*)' --------------------------'
DO  k=0,n,2
  WRITE(*,20)k,e(k)
END DO
20      FORMAT(2X,i3,d22.12)
END PROGRAM meulera

SUBROUTINE eulera(n,en)

!       ======================================
!       Purpose: Compute Euler number En
!       Input :  n --- Serial number
!       Output:  EN(n) --- En
!       ======================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(OUT)            :: en(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

en(0)=1.0D0
DO  m=1,n/2
  s=1.0D0
  DO  k=1,m-1
    r=1.0D0
    DO  j=1,2*k
      r=r*(2.0D0*m-2.0D0*k+j)/j
    END DO
    s=s+r*en(2*k)
  END DO
  en(2*m)=-s
END DO
RETURN
END SUBROUTINE eulera


      SUBROUTINE lubksb(a,n,np,indx,b)
      INTEGER n,np,indx(n)
      REAL a(np,np),b(n)
      INTEGER i,ii,j,ll
      REAL sum
      ii=0
      do 12 i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do 11 j=ii,i-1
            sum=sum-a(i,j)*b(j)
11        continue
        else if (sum.ne.0.) then
          ii=i
        endif
        b(i)=sum
12    continue
      do 14 i=n,1,-1
        sum=b(i)
        do 13 j=i+1,n
          sum=sum-a(i,j)*b(j)
13      continue
        b(i)=sum/a(i,i)
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/lubksb.for


program projectile
    implicit none
    ! define constants
    real, parameter :: GRAVITY = 9.8
    real, parameter :: PI = 3.1415927

    ! Other Local variables
    real :: a, t, u, x, y
    real :: theta, v, vx, vy
    character(len=80) fmt

    ! Read values for a, t, and u from terminal
    read(*, *) a, t, u

    ! convert angle to radians
    a = a * PI / 180.0

    x = u * cos(a) * t
    y = u * sin(a) * t - 0.5 * GRAVITY * t * t
    vx = u * cos(a)
    vy = u * sin(a) - GRAVITY * t
    v = sqrt(vx*vx + vy*vy)
    theta = atan(vy / vx) * 180.0 / PI

    fmt = "('x:', f7.2, ',     y:', f7.1)"
    write(*, fmt) x, y
    fmt = "('v:', f7.2, ', theta:', f7.2)"
    write(*, fmt) v, theta
end program projectile


program cdemo2
    complex :: a = (5,3), b = (0.5, 6)        ! complex initializer
    real, parameter :: pi = 3.141592653589793 ! The constant "pi"
    complex, parameter :: i = (0, 1)          ! the imaginary unit "i" (sqrt(-1))
    complex :: abdiff, abquot, abpow, aconj, p2cart, newc
    real :: areal, aimag, anorm, rho = 10, theta = pi / 3.0, x = 2.3, y = 3.0
    integer, parameter :: n = 50
    integer :: j
    complex, dimension(0:n-1) :: unit_circle

    abdiff = a - b
    abquot = a / b
    abpow  = a ** b
    areal = real(a)               ! Real part
    aimag = imag(a)               ! Imaginary part
    newc = cmplx(x,y)             ! Creating a complex on the fly from two reals intrinsically
                                  !   (initializer only works in declarations)
    newc = x + y*i                ! Creating a complex on the fly from two reals arithmetically
    anorm = abs(a)                ! Complex norm (or "modulus" or "absolute value")
                                  !   (use CABS before Fortran 90)
    aconj = conjg(a)              ! Complex conjugate (same as real(a) - i*imag(a))
    p2cart = rho * exp(i * theta) ! Euler's polar complex notation to cartesian complex notation
                                  !   conversion (use CEXP before Fortran 90)

    ! The following creates an array of N evenly spaced points around the complex unit circle
    ! useful for FFT calculations, among other things
    unit_circle = exp(2*i*pi/n * (/ (j, j=0, n-1) /) )
end program cdemo2


      FUNCTION rtsafe(funcd,x1,x2,xacc)
      INTEGER MAXIT
      REAL rtsafe,x1,x2,xacc
      EXTERNAL funcd
      PARAMETER (MAXIT=100)
      INTEGER j
      REAL df,dx,dxold,f,fh,fl,temp,xh,xl
      call funcd(x1,fl,df)
      call funcd(x2,fh,df)
      if((fl.gt.0..and.fh.gt.0.).or.(fl.lt.0..and.fh.lt.0.))pause
     *'root must be bracketed in rtsafe'
      if(fl.eq.0.)then
        rtsafe=x1
        return
      else if(fh.eq.0.)then
        rtsafe=x2
        return
      else if(fl.lt.0.)then
        xl=x1
        xh=x2
      else
        xh=x1
        xl=x2
      endif
      rtsafe=.5*(x1+x2)
      dxold=abs(x2-x1)
      dx=dxold
      call funcd(rtsafe,f,df)
      do 11 j=1,MAXIT
        if(((rtsafe-xh)*df-f)*((rtsafe-xl)*df-f).ge.0..or. abs(2.*
     *f).gt.abs(dxold*df) ) then
          dxold=dx
          dx=0.5*(xh-xl)
          rtsafe=xl+dx
          if(xl.eq.rtsafe)return
        else
          dxold=dx
          dx=f/df
          temp=rtsafe
          rtsafe=rtsafe-dx
          if(temp.eq.rtsafe)return
        endif
        if(abs(dx).lt.xacc) return
        call funcd(rtsafe,f,df)
        if(f.lt.0.) then
          xl=rtsafe
        else
          xh=rtsafe
        endif
11    continue
      pause 'rtsafe exceeding maximum iterations'
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rtsafe.for


c     program DRDBLAS2
c>> 1996-06-18 DRDBLAS2 Krogh  Minor format change for C conversion.
c>> 1994-10-19 DRDBLAS2 Krogh  Changes to use M77CON
c>> 1991-11-27 DRDBLAS2 CLL
c>> 1987-12-09 Lawson  Initial Code.
c
c     Demonstrates the use of BLAS subroutines DROTG, DROT, DAXPY,
c     and DCOPY to implement an algorithm for solving a linear
c     least squares problem using sequential accumulation of the
c     data and Givens orthogonal transformations.
c     YTAB() contains rounded values of -2 + 2*X + 3*Exp(-X)
c     -----------------------------------------------------------------
c--D replaces "?": DR?BLAS2, ?ROTG, ?ROT, ?AXPY, ?COPY
c     -----------------------------------------------------------------
      integer MC, MC1, MXY
      parameter ( MC=3, MC1=MC+1, MXY=11 )
      integer IXY, J, NC, NC1, NXY
      double precision X, XTAB(MXY), Y, YTAB(MXY), W(MC1)
      double precision C, RG(MC1,MC1), S
      double precision COEF(MC), DIV, ESTSD, ZERO(1)
c
      data XTAB / 0.0d0,  .1d0,  .2d0,    .3d0,   .4d0,  .5d0,
     *             .6d0,  .7d0,  .8d0,    .9d0,  1.0d0 /
      data YTAB / 1.00d0, .91d0, .86d0,   .82d0,  .81d0, .82d0,
     *             .85d0, .89d0, .95d0,  1.02d0, 1.10d0 /
      data NXY, NC / MXY, MC /
      data ZERO(1) / 0.0d0 /
c     -----------------------------------------------------------------
      NC1 = NC + 1
      call DCOPY(MC1*MC1, ZERO, 0, RG, 1)
      do 20 IXY = 1, NXY
        X = XTAB(IXY)
        Y = YTAB(IXY)
c                                      Build new row of [A:B] in W().
        W(1) = 1.0d0
        W(2) = X
        W(3) = exp(-X)
        W(4) = Y
c                                      Process W() into [R:G].
        do 10 J = 1, NC
          call DROTG(RG(J,J),W(J),C,S)
          call DROT(NC1-J,RG(J,J+1),MC1,W(J+1),1,C,S)
   10   continue
        call DROTG(RG(NC1,NC1),W(NC1),C,S)
   20 continue
c                                      Begin: Solve triangular system.
        call DCOPY(NC,RG(1,NC1),1,COEF,1)
        do 30 J = NC, 1, -1
          DIV = RG(J,J)
          if (DIV .eq. 0.0d0) then
            print '(''ERROR:ZERO DIVISOR AT J ='', I2)', J
            stop
          end if
          COEF(J) = COEF(J) / DIV
          call DAXPY(J-1,-COEF(J),RG(1,J),1,COEF,1)
   30   continue
c                                        End: Solve triangular system.
c
      print'('' Solution: COEF() = '',3f8.3)',(COEF(J),J=1,NC)
      ESTSD = abs(RG(NC1,NC1)) / sqrt(DBLE(NXY-NC))
      print'(/'' Estimated Std. Dev. of data errors ='',f9.5)', ESTSD
      stop
      end


module runge_kutta
    implicit none
    public order_4_step, ode_interface
    interface
        function ode_interface(t, y, rpar, ipar)
            integer, intent(in), optional :: ipar(:)
            real(8), intent(in) :: t
            real(8), intent(in) :: y(:)
            real(8), intent(in), optional :: rpar(:)
            real(8) :: ode_interface(size(y))
        end function ode_interface
    end interface
contains
function order_4_step(f, t, y, h, rpar, ipar)
    procedure(ode_interface) :: f
    integer, intent(in), optional :: ipar(:)
    real(8), intent(in) :: t
    real(8), intent(in) :: h
    real(8), intent(in) :: y(:)
    real(8), intent(in), optional :: rpar(:)
    real(8) :: order_4_step(size(y))
    real(8) :: k(4,size(y))
    integer :: i
    k(1,:) = h/6.d0*f(t, y, rpar, ipar)
    k(2,:) = h/3.d0*f(t + 1.d0/2.d0*h, y + 1.d0/2.d0*k(1,:), rpar, ipar)
    k(3,:) = h/3.d0*f(t + 1.d0/2.d0*h, y + 1.d0/2.d0*k(2,:), rpar, ipar)
    k(4,:) = h/6.d0*f(t + h, y + k(3,:), rpar, ipar)
    do i = 1, size(y)
        order_4_step(i) = y(i) + sum(k(:,i))
    end do
    return
end function order_4_step
end module runge_kutta