! **********************************************************************************
! *       ROUTINES FOR COMPUTING THE SPHERICAL BESSEL AND HANKEL FUNCTIONS,        *
! *    THE CYLINDRICAL BESSEL FUNCTIONS AND THE ASSOCIATED LEGENDRE FUNCTIONS      *
! *    -------------------------------------------------------------------------   *
! *    Partial list of subroutines:                                                *
! *      besel_j,                 besel_h,              besel_h_complete,          *
! *      J01,                     bes_J,                Pmm,                       *
! *      pimm,                    Leg,                  P_mm_real,                 *
! *      pi_mm_real,              tau_mm_real,          Leg_normalized,            *
! *      P_mm,                    pi_mm,                tau_mm,                    *
! *      Leg_normalized_complex                                                    *
! *    Partial list of alternative subroutines:                                    *
! *      besel_jA,                besel_hA,             besel_h_completeA,         *
! *      besel_jB,                besel_jC,             bes_JA,                    *
! *      MSTA1,                   MSTA2,                ENVJ                       *
! **********************************************************************************
subroutine besel_j (z, N, j, jd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel functions j(z) and the derivatives     !
! jd(z) = d(z*j(z))/dz. The order of the Bessel functions varies between 0 and N,  !
! and the backward recurrence relation                                             !
!                     j(n-1,z) + j(n+1,z) = [(2n+1) / z] * j(n,z).                 !
! is used for computation. Here j(n,z) denotes the Bessel function of order n and  !
! argument z. The following parameters control the computation:                    !
! - ZeroSinXX (real) - for |z| < ZeroSinXX, we set j(0,z) = sin(z)/z = 1 and       !
!   j(n,z) = 0, for n = 1,2,...,N.                                                 !
! - FactNBes (real) - determines the order of the Bessel functions Nstart,         !
!   at which the backward recurrence is started, i.e., Nstart = FactNBes * N.      !
!   Default value: FactNBes = 400._O.                                              !
! - InitBesVal (real) - initial value of the Bessel function at the beginning of   !
!   the backward recurrence. Default value: InitBesVal = 1.e-35_O.                 !
! - MaxArgBes (real) - for |z| > MaxArgBes, the asymptotic expressions of          !
!   spherical Bessel functions for large arguments are used.                       !
! - UpperBoundSeq (real) - upper bound of the sequence of Bessel functions         !
!   (if a Bessel function value exceeds this bound the entire sequence is scaled). !
!   Default value: UpperBoundSeq = 1.e+10_O.                                       !
! - LowerBoundSeq (real) - lower bound of the sequence of Bessel functions.        !
!   Default value: LowerBoundSeq = 1.e-10_O.                                       !
! These parameters are specified in the routine "DrvParameters" from the file      !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel functions.                      !
! - N (integer) - maximum order of the spherical Bessel functions.                 !
!                                                                                !
! Output parameters:                                                               !
! - j  (complex array) - spherical Bessel functions.                               !
! - jd (complex array) - derivatives of the spherical Bessel functions.            !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), jd(0:N)
!
  complex(O) :: j0, j1, f2, f1, f, kc, scale, argc
  real(O)    :: a0, arg
  integer    :: M, Ma, Mn, k, l
!
  a0 = abs(z)
  do k = 0, N
    j(k)  = zero
    jd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else if (a0 >= ZeroSinXX .and. a0 < MaxArgBes) then
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      j0 = j(0)
      j1 = j(1)
      Ma = nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 20
      Mn = N + nint(sqrt(FactNBes * N))
      M  = max(Ma,Mn)
      f2 = zero
      f1 = cmplx(InitBesVal,0.0,O)
      do k = M, 0, -1
        kc = cmplx(2 * k + 3,0.0,O)
        f  = kc * f1 / z - f2
        if (k <= N) j(k) = f
        f2 = f1
        f1 = f
        if (abs(f1) > UpperBoundSeq) then
          f2 = f2 * LowerBoundSeq
          f1 = f1 * LowerBoundSeq
          do l = k, N
            j(l) = j(l) * LowerBoundSeq
          end do
        else if (abs(f1) < LowerBoundSeq) then
          f2 = f2 * UpperBoundSeq
          f1 = f1 * UpperBoundSeq
          do l = k, N
            j(l) = j(l) * UpperBoundSeq
          end do
        end if
      end do
      if (abs(f1) > abs(f2)) then
        scale = j0 / f1
      else
        scale = j1 / f2
      end if
      do k = 0, N
        j(k) = scale * j(k)
      end do
    end if
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      jd(k) = z * j(k-1) - kc * j(k)
    end do
  else
    do k = 0, N
      arg  = 0.5_O * real(k + 1,O) * pi
      argc = cmplx(arg,0.0,O)
      j(k) = cos (z - argc) / z
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      jd(k) = z * j(k-1) - kc * j(k)
    end do
  end if
end subroutine besel_j
!**********************************************************************************
subroutine besel_h (z, N, h, hd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Hankel functions of the first kind            !
! h(z) = j(z) + i*y(z) and the derivatives hd(z) = d(z*h(z))/dz, where j(z) and    !
! y(z) are the spherical Bessel and Neumann functions, respectively. The order of  !
! the functions varies between 0 and N, and the control parameters ZeroSinXX,      !
! FactNBes, InitBesVal, UpperBoundSeq and LowerBoundSeq are specified in the       !
! routine "DrvParameters" from the file '../TMATROUTINES/MachParam.f90'.           !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Hankel functions.                      !
! - N (integer) - maximum order of the spherical Hankel functions.                 !
!                                                                                !
! Output parameters:                                                               !
! - h  (complex array) - spherical Hankel functions.                               !
! - hd (complex array) - derivatives of the spherical Hankel functions.            !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, h(0:N), hd(0:N)
!
  integer    :: Ma, Mn, M, k, l
  real(O)    :: a0, arg
  complex(O) :: j0, j1, f, f1, f2, kc, z2, z3, scale, argc
  complex(O),allocatable :: j(:), y(:)
!
  z2 = z * z
  z3 = z2 * z
  a0 = abs(z)
  allocate (j(0:N), y(0:N))
  do k = 0, N
    j(k)  = zero
    y(k)  = zero
    h(k)  = zero
    hd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else if (a0 >= ZeroSinXX .and. a0 < MaxArgBes) then
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      j0 = j(0)
      j1 = j(1)
      Ma = nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 20
      Mn = N + nint(sqrt(FactNBes * N))
      M  = max(Ma,Mn)
      f2 = zero
      f1 = cmplx(InitBesVal,0.0,O)
      do k = M, 0, -1
        kc = cmplx(2 * k + 3,0.0,O)
        f  = kc * f1 / z - f2
        if (k <= N) j(k) = f
        f2 = f1
        f1 = f
        if (abs(f1) > UpperBoundSeq) then
          f2 = f2 * LowerBoundSeq
          f1 = f1 * LowerBoundSeq
          do l = k, N
            j(l) = j(l) * LowerBoundSeq
          end do
        else if (abs(f1) < LowerBoundSeq) then
          f2 = f2 * UpperBoundSeq
          f1 = f1 * UpperBoundSeq
          do l = k, N
            j(l) = j(l) * UpperBoundSeq
          end do
        end if
      end do
      if (abs(f1) > abs(f2)) then
        scale = j0 / f1
      else
        scale = j1 / f2
      end if
      do k = 0, N
        j(k) = scale * j(k)
      end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (N >= 2) then
      do k = 2, N
        if (abs(j(k-1)) > abs(j(k-2))) then
          y(k) = (j(k) * y(k-1) - one / z2) / j(k-1)
        else
          kc   = cmplx(2 * k - 1,0.0,O)
          y(k) = (j(k) * y(k-2) - kc / z3) / j(k-2)
        end if
      end do
    end if
    do k = 0, N
      h(k) = j(k) + im * y(k)
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  else
    do k = 0, N
      arg  = 0.5_O * real(k + 1,O) * pi
      argc = cmplx(arg,0.0,O)
      h(k) = exp(im * (z - argc)) / z
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  end if
  deallocate (j, y)
end subroutine besel_h
!**********************************************************************************
subroutine besel_h_complete (z, N, j, y, h, hd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel and Neumann functions j(z) and y(z),   !
! the spherical Hankel functions of the first kind h(z) = j(z) + i*y(z) and the    !
! derivatives hd(z) = d(z*h(z))/dz. The order of the functions varies between 0    !
! and N, and the control parameters ZeroSinXX, FactNBes, InitBesVal, UpperBoundSeq !
! and LowerBoundSeq are specified in the routine "DrvParameters" from the file     !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel, Neumann and Hankel functions.  !
! - N (integer) - maximum order of the spherical functions.                        !
!                                                                                !
! Output parameters:                                                               !
! - j  (complex array) - spherical Bessel functions.                               !
! - y  (complex array) - spherical Neumann functions.                              !
! - h  (complex array) - spherical Hankel functions.                               !
! - hd (complex array) - derivatives of the spherical Hankel functions.            !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), y(0:N), h(0:N), hd(0:N)
!
  integer    :: Ma, Mn, M, k, l
  real(O)    :: a0, arg
  complex(O) :: j0, j1, f, f1, f2, kc, z2, z3, scale, argc
!
  z2 = z * z
  z3 = z2 * z
  a0 = abs(z)
  do k = 0, N
    j(k)  = zero
    y(k)  = zero
    h(k)  = zero
    hd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else if (a0 >= ZeroSinXX .and. a0 < MaxArgBes) then
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      j0 = j(0)
      j1 = j(1)
      Ma = nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 20
      Mn = N + nint(sqrt(FactNBes * N))
      M  = max(Ma,Mn)
      f2 = zero
      f1 = cmplx(InitBesVal,0.0,O)
      do k = M, 0, -1
        kc = cmplx(2 * k + 3,0.0,O)
        f  = kc * f1 / z - f2
        if (k <= N) j(k) = f
        f2 = f1
        f1 = f
        if (abs(f1) > UpperBoundSeq) then
          f2 = f2 * LowerBoundSeq
          f1 = f1 * LowerBoundSeq
          do l = k, N
            j(l) = j(l) * LowerBoundSeq
          end do
        else if (abs(f1) < LowerBoundSeq) then
          f2 = f2 * UpperBoundSeq
          f1 = f1 * UpperBoundSeq
          do l = k, N
            j(l) = j(l) * UpperBoundSeq
          end do
        end if
      end do
      if (abs(f1) > abs(f2)) then
        scale = j0 / f1
      else
        scale = j1 / f2
      end if
      do k = 0, N
        j(k) = scale * j(k)
      end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (N >= 2) then
      do k = 2, N
        if (abs(j(k-1)) > abs(j(k-2))) then
          y(k) = (j(k) * y(k-1) - one / z2) / j(k-1)
        else
          kc   = cmplx(2 * k - 1,0.0,O)
          y(k) = (j(k) * y(k-2) - kc / z3) / j(k-2)
        end if
      end do
    end if
    do k = 0, N
      h(k) = j(k) + im * y(k)
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  else
    do k = 0, N
      arg  = 0.5_O * real(k + 1,O) * pi
      argc = cmplx(arg,0.0,O)
      j(k) = cos (z - argc) / z
      y(k) = sin (z - argc) / z
      h(k) = j(k) + im * y(k)
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  end if
end subroutine besel_h_complete
!***********************************************************************************
subroutine J01 (z, J0, J1)
  use parameters
  use derived_parameters
  implicit none
  complex(O) :: z, J0, J1
!
  complex(O) :: z2, z1, r, t1, p0, q0, u, t2, p1, q1, kc
  real(O)    :: a0, rp2, A(12), B(12), A1(12), B1(12)
  integer    :: k, k0
!
  rp2 = 2._O / pi
  a0  = abs(z)
  z2  = z * z
  z1  = z
  if (a0 == 0._O) then
    J0 = one
    J1 = zero
  else
    if (real(z) < 0._O) z1 = - z
    if (a0 <= 12._O) then
      J0 = one
      r  = one
      do k = 1, 40
        kc = cmplx(k * k,0.0,O)
        r  = - 0.25_O * r * z2 / kc
        J0 = J0 + r
        if (abs(r) < MachEps * abs(J0)) exit
      end do
      J1 = one
      r  = one
      do k = 1, 40
        kc = cmplx(k * (k + 1),0.0,O)
        r  = - 0.25_O * r * z2 / kc
        J1 = J1 + r
        if (abs(r) < MachEps * abs(J1)) exit
      end do
      J1 = 0.5_O * z1 * J1
    else
      A  = (/-.703125e-01_O          , .1121520996093750e+00_O,                     &
             -.5725014209747314e+00_O, .6074042001273483e+01_O,                     &
             -.1100171402692467e+03_O, .3038090510922384e+04_O,                     &
             -.1188384262567832e+06_O, .6252951493434797e+07_O,                     &
             -.4259392165047669e+09_O, .3646840080706556e+11_O,                     &
             -.3833534661393944e+13_O, .4854014686852901e+15_O/)
      B  = (/ .732421875e-01_O       ,-.2271080017089844e+00_O,                     &
              .1727727502584457e+01_O,-.2438052969955606e+02_O,                     &
              .5513358961220206e+03_O,-.1825775547429318e+05_O,                     &
              .8328593040162893e+06_O,-.5006958953198893e+08_O,                     &
              .3836255180230433e+10_O,-.3649010818849833e+12_O,                     &
              .4218971570284096e+14_O,-.5827244631566907e+16_O/)
      A1 = (/ .1171875e+00_O         ,-.1441955566406250e+00_O,                     &
              .6765925884246826e+00_O,-.6883914268109947e+01_O,                     &
              .1215978918765359e+03_O,-.3302272294480852e+04_O,                     &
              .1276412726461746e+06_O,-.6656367718817688e+07_O,                     &
              .4502786003050393e+09_O,-.3833857520742790e+11_O,                     &
              .4011838599133198e+13_O,-.5060568503314727e+15_O/)
      B1 = (/-.1025390625e+00_O      , .2775764465332031e+00_O,                     &
             -.1993531733751297e+01_O, .2724882731126854e+02_O,                     &
             -.6038440767050702e+03_O, .1971837591223663e+05_O,                     &
             -.8902978767070678e+06_O, .5310411010968522e+08_O,                     &
             -.4043620325107754e+10_O, .3827011346598605e+12_O,                     &
             -.4406481417852278e+14_o, .6065091351222699e+16_O/)
      k0 = 12
      if (a0 >= 35._O) k0 = 10
      if (a0 >= 50._O) k0 = 8
      t1 = z1 - 0.25_O * pi
      p0 = one
      do k = 1, k0
        p0 = p0 + A(k) * z1**(- 2 * k)
      end do
      q0 = - 0.125_O / z1
      do k = 1, k0
        q0 = q0 + B(k) * z1**(- 2 * k - 1)
      end do
      u  = sqrt(rp2 / z1)
      J0 = u * (p0 * cos(t1) - q0 * sin(t1))
      t2 = z1 - 0.75_O * pi
      p1 = one
      do k = 1, k0
        p1 = p1 + A1(k) * z1**(- 2 * k)
      end do
      q1 = 0.375_O / z1
      do k = 1, k0
        q1 = q1 + B1(k) * z1**(- 2 * k - 1)
      end do
      J1 = u * (p1 * cos(t2) - q1 * sin(t2))
    end if
    if (real(z) < 0._O) then
      J1 = - J1
    end if
  end if
end subroutine J01
!***********************************************************************************
subroutine bes_J (z, N, J)
!-----------------------------------------------------------------------------------
! The routine computes the cylindrical Bessel function J(z). The order of the      !
! Bessel function varies between 0 and N, and the control parameters ZeroSinXX,    !
! FactNBes, InitBesVal, UpperBoundSeq and LowerBoundSeq are specified in the       !
! routine "DrvParameters" from the file '../TMATROUTINES/MachParam.f90'.           !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the cylindrical Bessel functions.                    !
! - N (integer) - maximum order of cylindrical Bessel functions.                   !
!                                                                                !
! Output parameters:                                                               !
! - J (complex array) - cylindrical Bessel functions.                              !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, J(0:N)
!
  complex(O) :: J0, J1, S, S0, f2, f1, f, kc
  real(O)    :: y0, a0
  integer    :: k, M, Ma, Mn, l
!
  y0 = abs(aimag(z))
  a0 = abs(z)
  do k = 0, N
    J(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    J(0) = one
  else
    call J01 (z, J0, J1)
    J(0) = J0
    J(1) = J1
    if (N > 1) then
      if (a0 <= 300._O .or. N > int(0.25_O * a0)) then
        Ma = nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 10
        Mn = N + nint(sqrt(FactNBes * N))
        M  = max(Ma,Mn)
        S  = zero
        f2 = zero
        f1 = cmplx(InitBesVal,0.0,O)
        do k = M, 0, -1
          kc = cmplx(k + 1,0.0,O)
          f  = 2._O * kc / z * f1 - f2
          if (k <= N) J(k) = f
          if (k == 2 * int(k / 2) .and. k /= 0) then
            if (y0 <= 1._O) then
              S = S + 2._O * f
            else
              S = S + (- 1._O)**(k / 2) * 2._O * f
            end if
          end if
          f2 = f1
          f1 = f
          if (abs(f1) > UpperBoundSeq) then
            f2 = f2 * LowerBoundSeq
            f1 = f1 * LowerBoundSeq
            S  = S * LowerBoundSeq
            do l = k, N
              J(l) = J(l) * LowerBoundSeq
            end do
          else if (abs(f1) < LowerBoundSeq) then
            f2 = f2 * UpperBoundSeq
            f1 = f1 * UpperBoundSeq
            S  = S * UpperBoundSeq
            do l = k, N
              J(l) = J(l) * UpperBoundSeq
            end do
          end if
        end do
        if (y0 <= 1._O) then
          S0 = S + f1
        else
          S0 = (S + f1) / cos(z)
        end if
        do k = 0, N
          J(k) = J(k) / S0
        end do
      else
        do k = 2, N
          kc   = cmplx(k - 1,0.0,O)
          J(k) = 2._O * kc / z * J(k-1) - J(k-2)
        end do
      end if
    end if
  endif
end subroutine bes_J
!***********************************************************************************
subroutine Pmm (theta, m, Pm)
!-----------------------------------------------------------------------------------
! The routine computes the Legendre function Pmm(theta) for m > 0.                 !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: k, m
  real(O) :: theta, Pm, tamp, f, sth
!
  sth  = sin(theta)
  tamp = 1._O
  do k = 1, m
    f    = real(2 * k - 1,O)
    tamp = f * sth * tamp
  end do
  Pm = tamp
end subroutine Pmm
!***********************************************************************************
subroutine pimm (theta, m, pim)
!-----------------------------------------------------------------------------------
! The routine computes the auxiliary function pimm,                                !
!                    pimm(theta) = Pmm[cos(theta)] / sin(theta)                    !
! for m > 1.                                                                       !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: k, m
  real(O) :: theta, pim, tamp, f, sth
!
  sth  = sin(theta)
  tamp = 1._O
  do k = 1, m - 1
    f    = real(2 * k - 1,O)
    tamp = f * sth * tamp
  end do
  f   = real(2 * m - 1,O)
  pim = f * tamp
end subroutine pimm
!***********************************************************************************
subroutine Leg (theta, m, Nmax, Pnm, dPnm, pinm, taunm)
!-----------------------------------------------------------------------------------
! The routine computes the associated Legendre functions Pnm[cos(theta)], the      !
! derivatives dPn0[cos(theta)] = dPn0[cos(theta)]/d[cos(theta)], and the auxiliary !
! functions pinm(theta) = Pnm[cos(theta)]/sin(theta), and taunm(theta) =           !
! dPnm[cos(theta)]/d(theta) of degree m. The order of the associated Legendre      !
! functions varies between 0 and Nmax, and note that for m > 0, the first m values !
! of Pnm, pinm and taunm (corresponding to the orders 0, 1, ..., m - 1) are zero.  !
! The derivatives dPn0 are computed for the azimuthal mode m = 0 (for m >0, the    !
! Nmax values of dPn0 are zero).                                                   !
!                                                                                !
! Input parameteres:                                                               !
! - theta (real) - polar angle (argument of the associated Legendre functions).    !
! - m (integer) - degree of the associated Legendre functions.                     !
! - Nmax (integer) - maximum order of the associated Legendre functions.           !
!                                                                                !
! Output parameters:                                                               !
! - Pnm (real array) - associated Legendre functions.                              !
! - dPnm (real array) - derivatives of the associated Legendre functions           !
!   for m = 0.                                                                     !
! - pinm and taunm (real arrays) - auxiliary functions.                            !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  real(O) :: theta
  integer :: m, Nmax
  real(O) :: Pnm(0:Nmax), dPnm(0:Nmax), pinm(0:Nmax), taunm(0:Nmax)
!
  real(O) :: Pm, pim, f1, f2, cth, sth
  integer :: n
!
  cth = cos(theta)
  sth = sin(theta)
  if (m == 0) then
    Pnm(0) = 1._O
    Pnm(1) = cth
    do n = 1, Nmax - 1
      f1 = real(2 * n + 1,O) / real(n + 1,O)
      f2 = real(n,O) / real(n + 1,O)
      Pnm(n+1) = f1 * cth * Pnm(n) - f2 * Pnm(n-1)
    end do
  else
    do n = 0, m - 1
      Pnm(n) = 0._O
    end do
    call Pmm (theta, m, Pm)
    Pnm(m) = Pm
    do n = m, Nmax - 1
      f1 = real(2 * n + 1,O) / real(n + 1 - m,O)
      f2 = real(n + m,O) / real(n + 1 - m,O)
      Pnm(n+1) = f1 * cth * Pnm(n) - f2 * Pnm(n-1)
    end do
  end if
  if (m == 0) then
    dPnm(0) = 0._O
    do n = 1, Nmax
      f1 = real(n,O)
      dPnm(n) = f1 * Pnm(n-1) + cth * dPnm(n-1)
    end do
  else
    do n = 0, Nmax
      dPnm(n) = 0._O
    end do
  end if
  if (m == 0) then
    do n = 0, Nmax
      pinm(n)  =   0._O
      taunm(n) = - sth * dPnm(n)
    end do
  else
    if (m == 1) then
      pinm(0)  = 0._O
      taunm(0) = 0._O
      pinm(1)  = 1._O
    else
      do n = 0, m - 1
        pinm(n)  = 0._O
        taunm(n) = 0._O
      end do
      call pimm (theta, m, pim)
      pinm(m) = pim
    end if
    do n = m, Nmax - 1
      f1 = real(2 * n + 1,O) / real(n + 1 - m,O)
      f2 = real(n + m,O) / real(n + 1 - m,O)
      pinm(n+1) = f1 * cth * pinm(n) - f2 * pinm(n-1)
    end do
    do n = m, Nmax
      f1 = real(n,O)
      f2 = real(n + m,O)
      taunm(n) = f1 * cth * pinm(n) - f2 * pinm(n-1)
    end do
  end if
end subroutine Leg
!***********************************************************************************
subroutine P_mm_real (theta, m, Pm)
!-----------------------------------------------------------------------------------
! The routine computes the normalized Legendre function Pmm(theta) of real         !
! argument (real angle).                                                           !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: k, m
  real(O) :: theta, Pm, tamp, f, cth, sth
!
  cth = cos(theta)
  sth = sin(theta)
  if (m == 0) then
    Pm = sqrt(3._O / 2._O) * cth
  else
    tamp = 1._O
    do k = 1, m
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = f * sth * tamp
    end do
    f  = sqrt(real(2 * m + 1,O) / 2._O)
    Pm = f * tamp
  end if
end subroutine P_mm_real
!***********************************************************************************
subroutine pi_mm_real (theta, m, pim)
!-----------------------------------------------------------------------------------
! The routine computes the normalized auxiliary function pimm,                     !
!                    pimm(theta) = Pmm[cos(theta)] / sin(theta)                    !
! of real argument (real angle).                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: k, m
  real(O) :: theta, pim, tamp, f, sth
!
  sth = sin(theta)
  if (m == 0) then
    pim = 0._O
  else
    tamp = 1._O
    do k = 1, m - 1
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = f * sth * tamp
    end do
    f   = sqrt(real(2 * m + 1,O)) / 2._O
    pim = f * tamp
  end if
end subroutine pi_mm_real
!***********************************************************************************
subroutine tau_mm_real (theta, m, taum)
!-----------------------------------------------------------------------------------
! The routine computes the normalized auxiliary function taumm,                    !
!                  taumm(theta) = dPmm[cos(theta)] / d(theta)                      !
! of real argument (real angle).                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: k, m
  real(O) :: theta, taum, tamp, f, cth, sth
!
  cth = cos(theta)
  sth = sin(theta)
  if (m == 0) then
    taum = - sqrt(3._O / 2._O) * sth
  else
    tamp = 1._O
    do k = 1, m - 1
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = f * sth * tamp
    end do
    f    = real(m,O) * sqrt(real(2 * m + 1,O)) / 2._O
    taum = f * cth * tamp
  end if
end subroutine tau_mm_real
!***********************************************************************************
subroutine Leg_normalized (theta, m, Nmax, Pnm, dPnm, pinm, taunm)
!------------------------------------------------------------------------------------
! The routine computes the normalized associated Legendre functions                 !
! Pnm[cos(theta)], the derivatives dPn0[cos(theta)] = dPn0[cos(theta)]/d[cos(theta)]!
! and the auxiliary functions pinm(theta) = Pnm[cos(theta)]/sin(theta), and         !
! taunm(theta) = dPnm[cos(theta)]/d(theta) of degree m. The order of the normalized !
! associated Legendre functions varies between 0 and Nmax, and note that for        !
! m > 0, the first m values of Pnm, pinm and taunm (corresponding to the orders     !
! 0, 1, ..., m - 1)are zero. The derivatives dPn0 are computed for the azimuthal    !
! mode m = 0 (for m >0, the Nmax values of dPn0 are zero).                          !
!                                                                                !
! Input parameteres:                                                                !
! - theta (real) - polar angle (argument of the normalized associated Legendre      !
!   functions).                                                                     !
! - m (integer) - degree of the normalized associated Legendre functions.           !
! - Nmax (integer) - maximum order of the normalized associated Legendre            !
!   functions.                                                                      !
!                                                                                !
! Output parameters:                                                                !
! - Pnm (real array) - normalized associated Legendre functions.                    !
! - dPnm (real array) - derivatives of the normalized associated Legendre           !
!   functions for m = 0.                                                            !
! - pinm and taunm (real arrays) - normalized auxiliary functions.                  !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  real(O) :: theta
  integer :: m, Nmax
  real(O) :: Pnm(0:Nmax), dPnm(0:Nmax), pinm(0:Nmax), taunm(0:Nmax)
!
  real(O) :: Pm, pim, f1, f2, cth, sth
  integer :: n
!
  cth = cos(theta)
  sth = sin(theta)
  if (m == 0) then
    Pnm(0) = sqrt(2._O) / 2._O
    Pnm(1) = sqrt(3._O / 2._O) * cos(theta)
    do n = 1, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * real(n,O) / real(n + 1,O)
      Pnm(n+1) = f1 * cth * Pnm(n) - f2 * Pnm(n-1)
    end do
  else
    do n = 0, m - 1
      Pnm(n) = 0._O
    end do
    call P_mm_real (theta, m, Pm)
    Pnm(m) = Pm
    do n = m, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1 - m,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1 + m,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n - m + 1,O))
      f2 = f2 * sqrt(real(n + m,O) / real(n + m + 1,O))
      Pnm(n+1) = f1 * cth * Pnm(n) - f2 * Pnm(n-1)
    end do
  end if
  if (m == 0) then
    dPnm(0) = 0._O
    do n = 1, Nmax
      f2 = sqrt(real(2 * n + 1,O) / real(2 * n - 1,O))
      f1 = real(n,O) * f2
      dPnm(n) = f1 * Pnm(n-1) + f2 * cth * dPnm(n-1)
    end do
  else
    do n = 0, Nmax
      dPnm(n) = 0._O
    end do
  end if
  if (m == 0) then
    do n = 0, Nmax
      pinm(n)  =   0._O
      taunm(n) = - sth * dPnm(n)
    end do
  else
    if (m == 1) then
      pinm(0)  = 0._O
      taunm(0) = 0._O
      pinm(1)  = sqrt(3._O) / 2._O
    else
      do n = 0, m - 1
        pinm(n)  = 0._O
        taunm(n) = 0._O
      end do
      call pi_mm_real (theta, m, pim)
      pinm(m) = pim
    end if
    do n = m, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1 - m,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1 + m,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n - m + 1,O))
      f2 = f2 * sqrt(real(n + m,O) / real(n + m + 1,O))
      pinm(n+1) = f1 * cth * pinm(n) - f2 * pinm(n-1)
    end do
    do n = m, Nmax
      f1 = real(n,O)
      f2 = sqrt(real(2 * n + 1,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n + m,O))
      f2 = f2 * real(n + m,O)
      taunm(n) = f1 * cth * pinm(n) - f2 * pinm(n-1)
    end do
  end if
end subroutine Leg_normalized
!***********************************************************************************
subroutine P_mm (sint, cost, m, Pm)
!-----------------------------------------------------------------------------------
! The routine computes the normalized Legendre function Pmm(theta) of complex      !
! argument (complex angle).                                                        !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer     :: k, m
  real(O)     :: f
  complex(O)  :: sint, cost, Pm, tamp
!
  if (m == 0) then
    Pm = sqrt(3._O/2._O) * cost
  else
    tamp = one
    do k = 1, m
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = f * sint * tamp
    end do
    f  = sqrt(real(2 * m + 1,O) / 2._O)
    Pm = f * tamp
  end if
end subroutine P_mm
!***********************************************************************************
subroutine pi_mm (sint, m, pim)
!-----------------------------------------------------------------------------------
! The routine computes the normalized auxiliary function                           !
!                     pimm(theta) = Pmm[cos(theta)] / sin(theta)                   !
! of complex argument (complex angle).                                             !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer     :: k, m
  real(O)     :: f
  complex(O)  :: sint, pim, tamp
!
  if (m == 0) then
    pim = zero
  else
    tamp = one
    do k = 1, m - 1
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = sint * f * tamp
    end do
    f   = sqrt(real(2 * m + 1,O)) / 2._O
    pim = f * tamp
  end if
end subroutine pi_mm
!***********************************************************************************
subroutine tau_mm (sint, cost, m, taum)
!-----------------------------------------------------------------------------------
! The routine computes the normalized auxiliary function                           !
!                      taumm(theta) = dPmm[cos(theta)] / d(theta)                  !
! of complex argument (complex angle).                                             !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer     :: k, m
  real(O)     :: f
  complex(O)  :: sint, cost, taum, tamp
!
  if (m == 0) then
    taum = - sqrt(3._O / 2._O) * sint
  else
    tamp = one
    do k = 1, m - 1
      f    = sqrt(real(m + k,O) / 4._O / real(k,O))
      tamp = f * sint * tamp
    end do
    f    = real(m,O) * sqrt(real(2 * m + 1,O)) / 2._O
    taum = f * cost * tamp
  end if
end subroutine tau_mm
!***********************************************************************************
subroutine Leg_normalized_complex (sint, cost, m, Nmax, Pnm, dPnm, pinm, taunm)
!------------------------------------------------------------------------------------
! The routine computes the normalized associated Legendre functions                 !
! Pnm[cos(theta)], the derivatives dPn0[cos(theta)] = dPn0[cos(theta)]/d[cos(theta)]!
! and the auxiliary functions pinm(theta) = Pnm[cos(theta)]/sin(theta), and         !
! taunm(theta) = dPnm[cos(theta)]/d(theta) of degree m and complex argument.        !
! The order of the normalized  associated Legendre functions varies between 0 and   !
! Nmax, and note that for m > 0, the first m values of Pnm, pinm and taunm          !
! (corresponding to the orders 0, 1, ..., m - 1) are zero. The derivatives dPn0     !
! are computed for the azimuthal mode m = 0 (for m >0, the Nmax values of dPn0      !
! are zero).                                                                        !
!                                                                                !
! Input parameteres:                                                                !
! - sint (complex) - sint = sin(theta), where theta is the complex polar angle.     !
! - cost (complex) - cost = cos(theta), where theta is the complex polar angle.     !
! - m (integer) - degree of the normalized associated Legendre functions.           !
! - Nmax (integer) - maximum order of the normalized associated Legendre            !
!   functions.                                                                      !
!                                                                                !
! Output parameters:                                                                !
! - Pnm (complex array) - normalized associated Legendre functions.                 !
! - dPnm (complex array) - derivatives of the normalized associated Legendre        !
!   functions for m = 0.                                                            !
! - pinm and taunm (complex arrays) - normalized auxiliary functions.               !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer     :: m, Nmax
  complex(O)  :: sint, cost
  complex(O)  :: Pnm(0:Nmax), dPnm(0:Nmax), pinm(0:Nmax), taunm(0:Nmax)
!
  complex(O)  :: Pm, pim
  real(O)     :: f1, f2
  integer     :: n
!
  if (m == 0) then
    Pnm(0) = cmplx(sqrt(2._O) / 2._O,0.0,O)
    Pnm(1) = sqrt(3._O / 2._O) * cost
    do n = 1, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * real(n,O) / real(n + 1,O)
      Pnm(n+1) = f1 * cost * Pnm(n) - f2 * Pnm(n-1)
    end do
  else
    do n = 0, m - 1
      Pnm(n) = zero
    end do
    call P_mm (sint, cost, m, Pm)
    Pnm(m) = Pm
    do n = m, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1 - m,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1 + m,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n - m + 1,O))
      f2 = f2 * sqrt(real(n + m,O) / real(n + m + 1,O))
      Pnm(n+1) = f1 * cost * Pnm(n) - f2 * Pnm(n-1)
    end do
  end if
  if (m == 0) then
    dPnm(0) = zero
    do n = 1, Nmax
      f2 = sqrt(real(2 * n + 1,O) / real(2 * n - 1,O))
      f1 = real(n,O) * f2
      dPnm(n) = f1 * Pnm(n-1) + f2 * cost * dPnm(n-1)
    end do
  else
    do n = 0, Nmax
      dPnm(n) = zero
    end do
  end if
  if (m == 0) then
    do n = 0, Nmax
      pinm(n)  =   zero
      taunm(n) = - sint * dPnm(n)
    end do
  else
    if (m == 1) then
      pinm(0)  = zero
      taunm(0) = zero
      pinm(1)  = cmplx(sqrt(3._O) / 2._O,0.0,O)
    else
      do n = 0, m - 1
        pinm(n)  = zero
        taunm(n) = zero
      end do
      call pi_mm (sint, m, pim)
      pinm(m) = pim
    end if
    do n = m, Nmax - 1
      f1 = sqrt(real(2 * n + 1,O) / real(n + 1 - m,O))
      f1 = f1 * sqrt(real(2 * n + 3,O) / real(n + 1 + m,O))
      f2 = sqrt(real(2 * n + 3,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n - m + 1,O))
      f2 = f2 * sqrt(real(n + m,O) / real(n + m + 1,O))
      pinm(n+1) = f1 * cost * pinm(n) - f2 * pinm(n-1)
    end do
    do n = m, Nmax
      f1 = real(n,O)
      f2 = sqrt(real(2 * n + 1,O) / real(2 * n - 1,O))
      f2 = f2 * sqrt(real(n - m,O) / real(n + m,O))
      f2 = f2 * real(n + m,O)
      taunm(n) = f1 * cost * pinm(n) - f2 * pinm(n-1)
    end do
  end if
end subroutine Leg_normalized_complex
! **********************************************************************************
! *       ALTERNATIVE ROUTINES FOR COMPUTING THE SPHERICAL BESSEL AND HANKEL       *
! *               FUNCTIONS AND THE CYLINDRICAL BESSEL FUNCTIONS                   *
! **********************************************************************************
subroutine besel_jA (z, N, j, jd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel functions j(z) and the derivatives     !
! jd(z) = d(z*j(z))/dz. The order of the Bessel functions varies between 0 and N,  !
! and the backward recurrence relation                                             !
!          csi(n,z) = 1.0 / ((2n+1) / z - csi(n+1,z)), n = Nstart,...,1,           !
! and the forward recurrence relations                                             !
!          j(n,z)   = csi(n,z) * j(n-1,z)                                          !
!          jd(n,z)  = ( z - n * csi(n,z)) * j(n-1,z),    n = 1,...,N,              !
! with j(0,z) = sin(z) / z, are used for computation. Here Nstart is the downward  !
! starting index and j(n,z) denotes the Bessel function of order n and argument z. !
! Note that:                                                                       !
!          csi(n,z) = j(n,z) / j(n-1,z).                                           !
! The following parmeters control the computation:                                 !
! - ZeroSinXX (real) - for |z| < ZeroSinXX, we set j(0,z) = sin(z)/z = 1 and       !
!   j(n,z) = 0, for n = 1,2,...,N.                                                 !
! - NIterBes (integer) - maximum number of backward recurrences. Default value     !
!   NIterBes = 5000.                                                               !
! - TolJ0Val (real) - if abs(j(0,z) - sin(z)/z) > TolJ0Val, the starting index     !
!   Nstart (of the backward recurrence) is increased by 20 and the recurrence is   !
!   restarted. Default value: TolJ0Val = MachEps**0.666_O                          !
! These parameters are specified in the routine "DrvParameters" from the file      !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel functions.                      !
! - N (integer) - maximum order of the spherical Bessel functions.                 !
!                                                                                !
! Output parameters:                                                               !
! - j  (complex array) - spherical Bessel functions.                               !
! - jd (complex array) - derivatives of the spherical Bessel functions.            !
!                                                                                !
! Note: This routine does not use the asymptotic expressions of spherical Bessel   !
! functions for large arguments.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), jd(0:N)
!
  integer    :: M, k
  real(O)    :: a0, deps
  complex(O) :: csin1, csin, fct, j0, kc
  logical    :: more
  complex(O),allocatable :: csi(:)
!
  a0 = abs(z)
  allocate (csi(N))
  do k = 0, N
    j(k)  = zero
    jd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else
    j(0)  = sin(z) / z
    j(1)  = j(0) / z - cos(z) / z
    jd(1) = z * j(0) - j(1)
    if (N >= 2) then
      M = N + nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 10
      more = .true.
      do while (more .and. M < NIterBes)
        csin1 = zero
        do k = M, 1, -1
          fct  = cmplx(2 * k + 1,0.0,O) / z
          csin = one / (fct - csin1)
          if (k <= N) csi(k) = csin
          csin1 = csin
        end do
        j(0) = cos(z) / (one - z * csi(1))
        j0   = sin(z) / z
        deps = abs (j0 - j(0))
        if (deps < TolJ0Val) then
          more = .false.
        else
          M = M + 20
        end if
      end do
      if (more) then
        print "(/,2x,'Error in subroutine besel_j:')"
        print "(2x,'the  csi  sequence can not be computed with the desired accuracy.')"
        print "(2x,'The tolerance TolJ0Val or the iteration number NIterBes specified')"
        print "(2x,'in the subroutine MachParam are too low.                         ')"
        stop
      end if
      j(1)  = csi(1) * j(0)
      jd(1) = (z - csi(1)) * j(0)
      do k = 2, N
        kc    = cmplx(k,0.0,O)
        j(k)  = csi(k) * j(k-1)
        jd(k) = (z - kc * csi(k)) * j(k-1)
      end do
    end if
  end if
  deallocate (csi)
end subroutine besel_jA
!**********************************************************************************
subroutine besel_hA (z, N, h, hd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Hankel functions of the first kind            !
! h(z) = j(z) + i*y(z) and the derivatives hd(z) = d(z*h(z))/dz, where j(z) and    !
! y(z) are the spherical Bessel and Neumann functions, respectively. The order of  !
! the functions varies between 0 and N, and the control parameters ZeroSinXX,      !
! NIterBes and TolJ0Val are specified in the routine "DrvParameters" from the file !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Hankel functions.                      !
! - N (integer) - maximum order of the spherical Hankel functions.                 !
!                                                                                !
! Output parameters:                                                               !
! - h  (complex array) - spherical Hankel functions.                               !
! - hd (complex array) - derivatives of the spherical Hankel functions.            !
!                                                                                !
! Note: This routine does not use the asymptotic expressions of spherical Bessel   !
! functions for large arguments.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, h(0:N), hd(0:N)
!
  integer    :: M, k
  real(O)    :: a0, deps
  complex(O) :: csin1, csin, fct, j0, kc, z2, z3
  logical    :: more
  complex(O),allocatable :: csi(:), j(:), y(:)
!
  z2 = z * z
  z3 = z2 * z
  a0 = abs(z)
  allocate (csi(N), j(0:N), y(0:N))
  do k = 0, N
    j(k)  = zero
    y(k)  = zero
    h(k)  = zero
    hd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      M = N + nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 10
      more = .true.
      do while (more .and. M < NIterBes)
        csin1 = zero
        do k = M, 1, -1
          fct  = cmplx(2 * k + 1,0.0,O) / z
          csin = one / (fct - csin1)
          if (k <= N) csi(k) = csin
          csin1 = csin
        end do
        j(0) = cos(z) / (one - z * csi(1))
        j0   = sin(z) / z
        deps = abs (j0 - j(0))
        if (deps < TolJ0Val) then
          more = .false.
        else
          M = M + 20
        end if
      end do
      if (more) then
        print "(/,2x,'Error in subroutine besel_h:')"
        print "(2x,'the  csi  sequence can not be computed with the desired accuracy.')"
        print "(2x,'The tolerance TolJ0Val or the iteration number NIterBes specified')"
        print "(2x,'in the subroutine MachParam are too low.                         ')"
        stop
      end if
      j(1) = csi(1) * j(0)
      do k = 2, N
        j(k) = csi(k) * j(k-1)
      end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (N >= 2) then
      do k = 2, N
        if (abs(j(k-1)) > abs(j(k-2))) then
          y(k) = (j(k) * y(k-1) - one / z2) / j(k-1)
        else
          kc   = cmplx(2 * k - 1,0.0,O)
          y(k) = (j(k) * y(k-2) - kc / z3) / j(k-2)
        end if
      end do
    end if
    do k = 0, N
      h(k) = j(k) + im * y(k)
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  end if
  deallocate (csi, j, y)
end subroutine besel_hA
!**********************************************************************************
subroutine besel_h_completeA (z, N, j, y, h, hd)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel and Neumann functions j(z) and y(z),   !
! the spherical Hankel functions of the first kind h(z) = j(z) + i*y(z) and the    !
! derivatives hd(z) = d(z*h(z))/dz. The order of the functions varies between 0    !
! and N, and the control parameters ZeroSinXX, NIterBes and TolJ0Val are specified !
! in the routine "DrvParameters" from the file '../TMATROUTINES/MachParam.f90'.    !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel, Neumann and Hankel functions.  !
! - N (integer) - maximum order of the spherical functions.                        !
!                                                                                !
! Output parameters:                                                               !
! - j  (complex array) - spherical Bessel functions.                               !
! - y  (complex array) - spherical Neumann functions.                              !
! - h  (complex array) - spherical Hankel functions.                               !
! - hd (complex array) - derivatives of the spherical Hankel functions.            !
!                                                                                !
! Note: This routine does not use the asymptotic expressions of spherical Bessel   !
! functions for large arguments.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), y(0:N), h(0:N), hd(0:N)
!
  integer    :: M, k
  real(O)    :: a0, deps
  complex(O) :: csin1, csin, fct, j0, kc, z2, z3
  logical    :: more
  complex(O),allocatable :: csi(:)
!
  z2 = z * z
  z3 = z2 * z
  a0 = abs(z)
  allocate (csi(N))
  do k = 0, N
    j(k)  = zero
    y(k)  = zero
    h(k)  = zero
    hd(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      M = N + nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 10
      more = .true.
      do while (more .and. M < NIterBes)
        csin1 = zero
        do k = M, 1, -1
          fct  = cmplx(2 * k + 1,0.0,O) / z
          csin = one / (fct - csin1)
          if (k <= N) csi(k) = csin
          csin1 = csin
        end do
        j(0) = cos(z) / (one - z * csi(1))
        j0   = sin(z) / z
        deps = abs (j0 - j(0))
        if (deps < TolJ0Val) then
          more = .false.
        else
          M = M + 20
        end if
      end do
      if (more) then
        print "(/,2x,'Error in subroutine besel_h_complete:')"
        print "(2x,'the  csi  sequence can not be computed with the desired accuracy.')"
        print "(2x,'The tolerance TolJ0Val or the iteration number NIterBes specified')"
        print "(2x,'in the subroutine MachParam are too low.                         ')"
        stop
      end if
      j(1) = csi(1) * j(0)
      do k = 2, N
        j(k) = csi(k) * j(k-1)
      end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (N >= 2) then
      do k = 2, N
        if (abs(j(k-1)) > abs(j(k-2))) then
          y(k) = (j(k) * y(k-1) - one / z2) / j(k-1)
        else
          kc   = cmplx(2 * k - 1,0.0,O)
          y(k) = (j(k) * y(k-2) - kc / z3) / j(k-2)
        end if
      end do
    end if
    do k = 0, N
      h(k) = j(k) + im * y(k)
    end do
    do k = 1, N
      kc    = cmplx(k,0.0,O)
      hd(k) = z * h(k-1) - kc * h(k)
    end do
  end if
  deallocate (csi)
end subroutine besel_h_completeA
! **********************************************************************************
subroutine besel_jB (z, N, j, y)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel functions j(z) and the spherical       !
! Neumann functions y(z). The order of the functions varies between 0 and N, and   !
! a backward recurrence relation is used to compute the Bessel functions, while    !
! an upward recurrence relation is employed to compute the spherical Neumann       !
! functions. The control parameters ZeroSinXX, FactNBes, InitBesVal, UpperBoundSeq !
! and LowerBoundSeq are specified in the routine "DrvParameters" from the file     !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel and Neumann functions.          !
! - N (integer) - maximum order of the spherical functions.                        !
!                                                                                !
! Output parameters:                                                               !
! - j (complex array) - spherical Bessel functions.                                !
! - y (complex array) - spherical Neumann functions.                               !
!                                                                                !
! Note: This routine does not use the asymptotic expressions of spherical Bessel   !
! functions for large arguments.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), y(0:N)
!
  complex(O) :: j0, j1, j2, f2, f1, f, kc, scale, z2, z3
  real(O)    :: a0, ajscale
  integer    :: M, Ma, Mn, k, l
!
  z2 = z * z
  z3 = z2 * z
  a0 = abs(z)
  do k = 0, N
    j(k) = zero
    y(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else
    j(0) = sin(z) / z
    j(1) = j(0) / z - cos(z) / z
    if (N >= 2) then
      j0 = j(0)
      j1 = j(1)
      j2 = 3._O * j1 / z - j0
      Ma = nint(a0 + 4._O * a0**0.33_O + 2._O + sqrt(101._O + a0)) + 10
      Mn = N + nint(sqrt(FactNBes * N))
      M  = max(Ma,Mn)
      f2 = zero
      f1 = cmplx(InitBesVal,0.0,O)
      do k = M - 1, N, -1
        kc = cmplx(2 * k + 1,0.0,O)
        f  = kc * f1 / z - f2
        f2 = f1
        f1 = f
        if (abs(f1) > UpperBoundSeq) then
          f2 = f2 * LowerBoundSeq
          f1 = f1 * LowerBoundSeq
        else if (abs(f1) < LowerBoundSeq) then
          f2 = f2 * UpperBoundSeq
          f1 = f1 * UpperBoundSeq
        end if
      end do
      j(N)   = f2
      j(N-1) = f1
      do k = N - 1, 1, -1
        kc = cmplx(2 * k + 1,0.0,O)
        j(k-1) = kc * j(k)/z - j(k+1)
        if (abs(j(k-1)) > UpperBoundSeq) then
          do l = k - 1, N
            j(l) = j(l) * LowerBoundSeq
          end do
        else if (abs(j(k-1)) < LowerBoundSeq) then
          do l = k - 1, N
            j(l) = j(l) * UpperBoundSeq
          end do
        end if
      end do
      ajscale = max(abs(j0), abs(j1), abs(j2))
      if (ajscale == abs(j0)) then
        scale = j0 / j(0)
      else if (ajscale == abs(j1)) then
        scale = j1 / j(1)
      else
        scale = j2 / j(2)
      end if
      do k = 0, N
        j(k) = scale * j(k)
      end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (N >= 2) then
      do k = 2, N
        if (abs(j(k-1)) > abs(j(k-2))) then
          y(k) = (j(k) * y(k-1) - 1._O / z2) / j(k-1)
        else
          kc   = cmplx(2 * k - 1,0.0,O)
          y(k) = (j(k) * y(k-2) - kc / z3) / j(k-2)
        end if
      end do
    end if
  end if
end subroutine besel_jB
!***********************************************************************************
subroutine besel_jC (z, N, j, y)
!-----------------------------------------------------------------------------------
! The routine computes the spherical Bessel functions j(z) and the spherical       !
! Neumann functions y(z). The order of the functions varies between 0 and N, and   !
! a backward recurrence relation is used to compute the Bessel functions, while    !
! an upward recurrence relation is employed to compute the spherical Neumann       !
! functions. The parameters which control the computation are ZeroSinXX,           !
! InitBesVal, UpperBoundSeq, LowerBoundSeq and LargestBesVal. LargestBesVal        !
! is real and denotes the largest (accepted) values of the spherical Neumann       !
! functions (default value: LargestBesVal = LargestPosNumber**0.333). These        !
! parameters are specified in the routine "DrvParameters" from the file            !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the spherical Bessel functions.                      !
! - N (integer) - maximum order of the spherical Bessel functions.                 !
!                                                                                !
! Output parameters:                                                               !
! - j (complex array) - spherical Bessel functions.                                !
! - y (complex array) - spherical Neumann functions.                               !
!                                                                                !
! Note: This routine does not use the asymptotic expressions of spherical Bessel   !
! functions for large arguments.                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, j(0:N), y(0:N)
!
  complex(O) :: j0, j1, j2, f2, f1, f, y0, y1, g0, g1, yk, h2, h1, h0, yl2, yl1,    &
                ylk, P11, P12, P21, P22, scale, z2, kc
  real(O)    :: a0, yak, ya1, wa, ya0, ajscale
  integer    :: NM, M, k, l, LB, LB0, MSTA1, MSTA2
!
  z2 = z * z
  a0 = abs(z)
  NM = N
  do k = 0, N
    j(k) = zero
    y(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    j(0) = one
  else
    j(0) = sin(z) / z
    j(1) = (j(0) - cos(z)) / z
    if (NM >= 2) then
       j0 = j(0)
       j1 = j(1)
       j2 = 3._O * j1 / z - j0
       M  = MSTA1 (a0, 200)
       if (M < N) then
         NM = M
       else
         M = MSTA2 (A0, N, 15)
       end if
       f2 = zero
       f1 = cmplx(InitBesVal,0.0,O)
       do k = M - 1, NM, -1
         kc = cmplx(2 * k + 1,0.0,O)
         f  = kc * f1 / z - f2
         f2 = f1
         f1 = f
         if (abs(f1) > UpperBoundSeq) then
           f2 = f2 * LowerBoundSeq
           f1 = f1 * LowerBoundSeq
         else if (abs(f1) < LowerBoundSeq) then
           f2 = f2 * UpperBoundSeq
           f1 = f1 * UpperBoundSeq
         end if
       end do
       j(NM)   = f2
       j(NM-1) = f1
       do k = NM - 1, 1, -1
         kc     = cmplx(2 * k + 1,0.0,O)
         j(k-1) = kc * j(k) / z - j(k+1)
         if (abs(j(k-1)) > UpperBoundSeq) then
           do l = k - 1, NM
             j(l) = j(l) * LowerBoundSeq
           end do
         else if (abs(j(k-1)) < LowerBoundSeq) then
           do l = k - 1, NM
             j(l) = j(l) * UpperBoundSeq
           end do
         end if
       end do
       ajscale = max(abs(j0), abs(j1), abs(j2))
       if (ajscale == abs(j0)) then
         scale = j0 / j(0)
       else if (ajscale == abs(j1)) then
         scale = j1 / j(1)
       else
         scale = j2 / j(2)
       end if
       do k = 0, NM
         j(k) = scale * j(k)
       end do
    end if
    y(0) = - cos(z) / z
    y(1) = (y(0) - sin(z)) / z
    if (NM >= 2) then
       y0  = y(0)
       y1  = y(1)
       ya0 = abs(y0)
       LB  = 0
       g0  = y0
       g1  = y1
       do k = 2, NM
         kc = cmplx(2 * k - 1,0.0,O)
         yk = kc / z * g1 - g0
         if (abs (yk) > LargestBesVal) exit
         yak = abs(yk)
         ya1 = abs(g0)
         if ((yak < ya0) .and. (yak < ya1)) LB = k
         y(k) = yk
         g0   = g1
         g1   = yk
       end do
       do while ((LB > 4) .and. (aimag(z) /= 0._O) .and. (LB /= LB0))
         h2  = one
         h1  = zero
         LB0 = LB
         do k = LB, 1, -1
           kc = cmplx(2 * k + 1,0.0,O)
           h0 = kc / z * h1 - h2
           h2 = h1
           h1 = h0
         end do
         P12 = h0
         P22 = h2
         h2  = zero
         h1  = one
         do k = LB, 1, -1
           kc = cmplx(2 * k + 1,0.0,O)
           h0 = kc / z * h1 - h2
           h2 = h1
           h1 = h0
         end do
         P11 = h0
         P21 = h2
         if (LB == NM) j(LB+1) = (2._O * LB + 1._O) / z * j(LB) - j(LB-1)
         if (abs(j(0)) > abs(j(1))) then
           y(LB+1) = (j(LB+1) * y0 - P11 / z2) / j(0)
           y(LB)   = (j(LB) * y0   + P12 / z2) / j(0)
         else
           y(LB+1) = (j(LB+1) * y1 - P21 / z2) / j(1)
           y(LB)   = (j(LB) * y1   + P22 / z2) / j(1)
         end if
         yl2 = y(LB+1)
         yl1 = y(LB)
         do k = LB - 1, 0, -1
           kc = cmplx(2 * k + 3,0.0,O)
           ylk = kc / z * yl1 - yl2
           y(k)= ylk
           yl2 = yl1
           yl1 = ylk
         end do
         yl1 = y(LB)
         yl2 = y(LB+1)
         do k = LB + 1, NM - 1
           kc     = cmplx(2 * k + 1,0.0,O)
           ylk    = kc /z * yl2 - yl1
           y(k+1) = ylk
           yl1    = yl2
           yl2    = ylk
         end do
         do k = 2, NM
           wa = abs(y(k))
           IF (wa < abs(y(k-1))) LB = k
         end do
       end do
    end if
  end if
end subroutine besel_jC
! **********************************************************************************
subroutine bes_JA (z, N, J)
!-----------------------------------------------------------------------------------
! The routine computes the cylindrical Bessel function J(z). The order of the      !
! Bessel functions varies between 0 and N, and the control parameters ZeroSinXX,   !
! InitBesVal, UpperBoundSeq and LowerBoundSeq are specified in the routine         !
! "DrvParameters" from the file '../TMATROUTINES/MachParam.f90'.                   !
!                                                                                !
! Input parameters:                                                                !
! - z (complex) - argument of the cylindrical Bessel functions.                    !
! - N (integer) - maximum order of cylindrical Bessel functions.                   !
!                                                                                !
! Output parameters:                                                               !
! - J (complex array) - cylindrical Bessel functions.                              !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: N
  complex(O) :: z, J(0:N)
!
  complex(O) :: J0, J1, f2, f1, f, scale, kc
  real(O)    :: a0
  integer    :: NM, M, k, l, MSTA1, MSTA2
!
  a0 = abs(z)
  NM = N
  do k = 0, N
    J(k) = zero
  end do
  if (a0 < ZeroSinXX) then
    J(0) = one
  else
    call J01 (z, J0, J1)
    J(0) = J0
    J(1) = J1
    if (N > 1) then
      if (N < int(0.25_O * a0)) then
        do k = 2, N
          kc   = cmplx(2 * (k - 1),0.0,O)
          J(k) = kc * J(k-1) / z - J(k-2)
        end do
      else
        M = MSTA1 (a0, 200)
        if (M < N) then
          NM = M
        else
          M = MSTA2 (A0, N, 15)
        end if
        f2 = zero
        f1 = cmplx(InitBesVal,0.0,O)
        do k = M, 0, -1
          kc = cmplx(2 * (k + 1),0.0,O)
          f  = kc * f1 / z - f2
          if (k <= NM) J(k) = f
          f2 = f1
          f1 = f
          if (abs(f1) > UpperBoundSeq) then
            f2 = f2 * LowerBoundSeq
            f1 = f1 * LowerBoundSeq
            do l = k, NM
              J(l) = J(l) * LowerBoundSeq
            end do
          else if (abs(f1) < LowerBoundSeq) then
            f2 = f2 * UpperBoundSeq
            f1 = f1 * UpperBoundSeq
            do l = k, NM
              J(l) = J(l) * UpperBoundSeq
            end do
          end if
        end do
        if (abs(f1) > abs(f2)) then
          scale = J0 / f1
        else
          scale = J1 / f2
        end if
        do k = 0, NM
          J(k) = scale * J(k)
        end do
      end if
    end if
  end if
end subroutine bes_JA
!***********************************************************************************
function MSTA1 (x, MP) result (MSTA)
  use parameters
  implicit none
  real(O), intent(in) :: x
  integer,intent(in)  :: MP
  integer             :: MSTA, N0, N1, it, NN
  real(O)             :: a0, f0, f1, f, ENVJ
!
  a0 = abs(x)
  if (a0 < 1._O) a0 = 1._O
  N0 = int(1.1_O * a0) + 1
  f0 = ENVJ(N0,a0) - MP
  N1 = N0 + 5
  f1 = ENVJ(N1,a0) - MP
  do it = 1, 50
    NN = N1 - int((N1 - N0) / (1._O - f0 / f1))
    f  = ENVJ(NN,a0) - MP
    if (abs(NN - N1) < 1) exit
    N0 = N1
    f0 = f1
    N1 = NN
    f1 = f
  end do
  MSTA = NN
end function MSTA1
!***********************************************************************************
function MSTA2 (x, N, MP) result (MSTA)
  use parameters
  implicit none
  real(O), intent(in) :: x
  integer,intent(in)  :: N, MP
  integer             :: MSTA, N0, N1, it, NN
  real(O)             :: a0, hmp, ejn, obj, f0, f1, f, ENVJ
!
  a0 = abs(X)
  if (a0 < 1._O) a0 = 1._O
  hmp = 0.5_O * MP
  ejn = ENVJ(N,a0)
  if (ejn <= hmp) then
    obj = 1._O * MP
    N0  = int(1.1_O * a0)
  else
    obj = hmp + ejn
    N0  = N
  end if
  f0 = ENVJ(N0,a0) - obj
  N1 = N0 + 5
  f1 = ENVJ(N1,A0) - obj
  do it = 1, 50
    NN = N1 - int((N1 - N0) / (1._O - f0 / f1))
    f  = ENVJ(NN,a0) - obj
    if (abs(NN - N1) < 1) exit
    N0 = N1
    f0 = f1
    N1 = NN
    f1 = f
  end do
  MSTA = NN + 10
end function MSTA2
!***********************************************************************************
function ENVJ (N, x) result (ENV)
  use parameters
  implicit none
  real(O), intent(in) :: x
  integer,intent(in)  :: N
  real(O)             :: ENV
!
  ENV = 0.5_O * log10(6.28_O * N) - N * log10(1.36_O * x / N)
end function ENVJ


      PROGRAM xsprspm
C     driver for routine sprspm
      INTEGER NP,NMAX
      PARAMETER(NP=5,NMAX=2*NP*NP+1)
      INTEGER i,j,k,ija(NMAX),ijb(NMAX),ijbt(NMAX),ijc(NMAX)
      REAL sa(NMAX),sb(NMAX),sbt(NMAX),sc(NMAX)
      REAL a(NP,NP),b(NP,NP),c(NP,NP),ab(NP,NP)
      DATA a/1.0,0.5,0.0,0.0,0.0,
     *     0.5,2.0,0.5,0.0,0.0,
     *     0.0,0.5,3.0,0.5,0.0,
     *     0.0,0.0,0.5,4.0,0.5,
     *     0.0,0.0,0.0,0.5,5.0/
      DATA b/1.0,1.0,0.0,0.0,0.0,
     *     1.0,2.0,1.0,0.0,0.0,
     *     0.0,1.0,3.0,1.0,0.0,
     *     0.0,0.0,1.0,4.0,1.0,
     *     0.0,0.0,0.0,1.0,5.0/
      call sprsin(a,NP,NP,0.5,NMAX,sa,ija)
      call sprsin(b,NP,NP,0.5,NMAX,sb,ijb)
      call sprstp(sb,ijb,sbt,ijbt)
C     specify tridiagonal output, using fact that a is tridiagonal
      do 11 i=1,ija(ija(1)-1)-1
        ijc(i)=ija(i)
11    continue
      call sprspm(sa,ija,sbt,ijbt,sc,ijc)
      do 14 i=1,NP
        do 13 j=1,NP
          ab(i,j)=0.0
          do 12 k=1,NP
            ab(i,j)=ab(i,j)+a(i,k)*b(k,j)
12        continue
13      continue
14    continue
      write(*,*) 'Reference matrix:'
      write(*,'(5f7.1)') ((ab(i,j),j=1,NP),i=1,NP)
      write(*,*) 'sprspm matrix (should show only tridiagonals):'
      do 16 i=1,NP
        do 15 j=1,NP
          c(i,j)=0.0
15      continue
16    continue
      do 18 i=1,NP
        c(i,i)=sc(i)
        do 17 j=ijc(i),ijc(i+1)-1
          c(i,ijc(j))=sc(j)
17      continue
18    continue
      write(*,'(5f7.1)') ((c(i,j),j=1,NP),i=1,NP)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsprspm.for


program writeSampleBinData

    ! Created by Manuel A. Diaz, ENSMA 2020

    implicit none

    !-------- initialize variables -------------------
    character(len=30) :: output_file0 = "fields_d0_it0.bin"
    character(len=30) :: output_file1 = "xp.dat"
    character(len=30) :: output_file2 = "yp.dat"
    character(len=30) :: output_file3 = "zp.dat"
    character(len=10) :: Nx_char
    character(len=10) :: Ny_char
    character(len=10) :: Nz_char

    integer              :: Nx, Ny, Nz       ! Array dimensions
    integer              :: output_file_id=3 ! File identifier
    real(8)              :: Lx, Ly, Lz       ! mesh Lengths
    real(8)              :: dx, dy, dz       ! mesh cell's sizes
    real(8), allocatable :: x(:), y(:), z(:) ! Axis points arrays
    real(8), allocatable :: p(:,:,:)         ! Buffer for array
    real(8)              :: IC_P0 = 1.0      ! Amplitude
    real(8)              :: IC_x0 = 0.5      ! x-center
    real(8)              :: IC_y0 = 0.5      ! y-center
    real(8)              :: IC_z0 = 0.5      ! z-center
    real(8)              :: IC_S0 = 0.31     ! Sigma
    integer              :: buff_lenght      ! Buffer length
    integer              :: i, j, k          ! dummy indexes

    !-------- Parse arguments from command -----------
    if ( command_argument_count() .NE. 3 ) then
        print*, "Mode of use: ./sample_binFields.run [Nx] [Ny] [Nz]"; stop
    else
        call get_command_argument(1,Nx_char); read(Nx_char,*) Nx
        call get_command_argument(2,Ny_char); read(Ny_char,*) Ny
        call get_command_argument(3,Nz_char); read(Nz_char,*) Nz
        print*, "Attemping to write ",Nx,"Nx",Ny,"Ny",Nz,"Nz array."
    end if

    !-------- Allocate space for the array -----------
    allocate( x(Nx) )
    allocate( y(Ny) )
    allocate( z(Nz) )
    allocate( p(Nx,Ny,Nz) )

    !-------- Build mesh grid axis -------------------
    Lx = 1.0; dx = Lx / (Nx-1)
    Ly = 1.0; dy = Ly / (Ny-1)
    Lz = 1.0; dz = Lz / (Nz-1)
    do i = 1,Nx
        x(i) = dx*real(i-1)
    end do
    do j = 1,Ny
        y(j) = dy*real(j-1)
    end do
    do k = 1,Nz
        z(k) = dz*real(k-1)
    end do

    !------ fill in the array with sample data -------
    do k = 1,Nz
        do j = 1,Ny
            do i = 1,Nx
                p(i,j,k) = IC_P0 * exp( -((x(i)-IC_x0)**2 + (y(j)-IC_y0)**2 + (z(k)-IC_z0)**2)/(IC_S0**2) )
            end do
        end do
    end do

    !------ write in data in a binary file -----------
    Inquire( iolength = buff_lenght ) p
    open (output_file_id,file=trim(output_file0), form='unformatted', access='direct', recl=buff_lenght)
    write(output_file_id,rec=1) p
    close(output_file_id)
    open (output_file_id,file=trim(output_file1), form='formatted', action='write')
    do i = 1, Nx
        write(output_file_id,'(F10.8)') x(i)
    end do
    close(output_file_id)
    open (output_file_id,file=trim(output_file2), form='formatted', action='write')
    do i = 1, Ny
        write(output_file_id,'(F10.8)') y(i)
    end do
    close(output_file_id)
    open (output_file_id,file=trim(output_file3), form='formatted', action='write')
    do i = 1, Nz
        write(output_file_id,'(F10.8)') z(i)
    end do
    close(output_file_id)

    ! If we reach this point then
    print*, "outputs: ", output_file0, output_file1, output_file2, output_file3
    deallocate(x)
    deallocate(y)
    deallocate(z)
    deallocate(p)

    end program writeSampleBinData


      subroutine mul66(rt,rtt,r)
      real*8 rt(6,6),r(6,6),rtt(6,6)
      do i=1,6
        do j=1,6
          do ia=1,6
            rtt(i,ia)=rt(i,j)*r(j,ia)+rtt(i,ia)
          end do
        end do
      end do
      end

      program test
      real*8 xj(6,6),w(6,6),w1(6,6)
      parameter(idump=0)
      integer i,j

      do i=1,6
        do j=1,6
          xj(i,j) = 0.0d0
          w1(i,j) = 0.0d0
          w(i,j) = i * 10.0d0 + j;
        end do
      end do

      xj(1,2) =  1.0d0
      xj(2,1) = -1.0d0
      xj(3,4) =  1.0d0
      xj(4,3) = -1.0d0
      xj(5,6) =  1.0d0
      xj(6,5) = -1.0d0

      call mul66(xj,w1,w)

      if (idump.ne.0) then
        write(6,*) 'w1 after call to mul66'
        do i = 1,6
          do j = 1,6
            write(6,'(D15.7)') w1(i,j)
          end do
        end do
      end if

      if (w1(1,1).ne.21.0d0) then
        call abort()
      end if

      end


module advance_module

  implicit none

  private

  public :: advance

contains

  subroutine advance(data,dx,dt)

    use multifab_module

    type(multifab) , intent(inout) :: data
    real(kind=dp_t), intent(in   ) :: dx
    real(kind=dp_t), intent(in   ) :: dt

    ! local variables
    integer :: lo(data%dim), hi(data%dim)
    integer :: dm, ng, i

    real(kind=dp_t), pointer :: dp(:,:,:,:)

    ! set these here so we don't have to pass them into the subroutine
    dm = data%dim
    ng = data%ng

    do i=1,nfabs(data)
       dp => dataptr(data,i)
       lo = lwb(get_box(data,i))
       hi = upb(get_box(data,i))
       select case(dm)
       case (2)
          call advance_2d(dp(:,:,1,:), ng, lo, hi, dx, dt)
       case (3)
          call advance_3d(dp(:,:,:,:), ng, lo, hi, dx, dt)
       end select
    end do

    ! fill ghost cells
    ! this only fills periodic ghost cells and ghost cells for neighboring
    ! grids at the same level.  Physical boundary ghost cells are filled
    ! using multifab_physbc.  But this problem is periodic, so this
    ! call is sufficient.
    call multifab_fill_boundary(data)

  end subroutine advance

  subroutine advance_2d(U, ng, lo, hi, dx, dt)

    integer          :: lo(2), hi(2), ng
    double precision :: U(lo(1)-ng:,lo(2)-ng:,:)
    double precision :: dx, dt

    double precision, allocatable :: dU(:,:,:), Unew(:,:,:)

    double precision, parameter :: third     = 1.d0/3.d0
    double precision, parameter :: twothirds = 2.d0/3.d0
    double precision, parameter :: fac1      = -1.d0/12.d0
    double precision, parameter :: fac2      =  4.d0/3.d0
    double precision, parameter :: fac3      = -5.0d0

    integer          :: i,j,ndo

    allocate(  dU(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,2))
    allocate(Unew(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,2))

    if (ng < 6) then
       print *,'NOT ENOUGH GHOST CELLS IN ADVANCE ',ng
       stop
    end if

    ! First call to get RHS = Lap(U)
    ndo = 4

    do j = lo(2)-ndo,hi(2)+ndo
       do i = lo(1)-ndo,hi(1)+ndo

          dU(i,j,1) = U(i,j,2)

          dU(i,j,2) = (  fac1 * ( U(i-2,j,1) + U(i+2,j,1) + &
                                  U(i,j-2,1) + U(i,j+2,1) ) &
                       + fac2 * ( U(i-1,j,1) + U(i+1,j,1) + &
                                  U(i,j-1,1) + U(i,j+1,1) ) &
                       + fac3 *   U(i,j,1)  ) / (dx*dx)
       end do
    end do

    ! First update
    ! This Unew lives at t^{n+1}
    Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) = &
                 U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) &
         + dt * dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

    ! Second call to get RHS = Lap(Unew)
    ndo = 2

    do j = lo(2)-ndo,hi(2)+ndo
       do i = lo(1)-ndo,hi(1)+ndo

          dU(i,j,1) = Unew(i,j,2)

          dU(i,j,2) = (  fac1 * ( Unew(i-2,j,1) + Unew(i+2,j,1) + &
                                  Unew(i,j-2,1) + Unew(i,j+2,1) ) &
                       + fac2 * ( Unew(i-1,j,1) + Unew(i+1,j,1) + &
                                  Unew(i,j-1,1) + Unew(i,j+1,1) ) &
                       + fac3 *   Unew(i,j,1)  ) / (dx*dx)
       end do
    end do

    ! Second update
    ! This Unew lives at t^{n+1/2}
    Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) =        &
                .75d0 *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
              + .25d0 * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
         + dt * .25d0 *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

    ! Third call to get RHS = Lap(Unew)
    ndo = 0

    do j = lo(2)-ndo,hi(2)+ndo
       do i = lo(1)-ndo,hi(1)+ndo

          dU(i,j,1) = Unew(i,j,2)

          dU(i,j,2) = (  fac1 * ( Unew(i-2,j,1) + Unew(i+2,j,1) + &
                                  Unew(i,j-2,1) + Unew(i,j+2,1) ) &
                       + fac2 * ( Unew(i-1,j,1) + Unew(i+1,j,1) + &
                                  Unew(i,j-1,1) + Unew(i,j+1,1) ) &
                       + fac3 *   Unew(i,j,1)  ) / (dx*dx)
       end do
    end do

    ! Third update
    ! This Unew lives at t^{n+1}
    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2) =        &
                third     *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
              + twothirds * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)   &
         + dt * twothirds *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,1:2)

    deallocate(dU,Unew)

  end subroutine advance_2d

  subroutine advance_3d(U, ng, lo, hi, dx, dt)

    integer          :: lo(3), hi(3), ng
    double precision :: U(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:,:)
    double precision :: dx, dt

    double precision, allocatable :: dU(:,:,:,:), Unew(:,:,:,:)

    double precision, parameter :: third     = 1.d0/3.d0
    double precision, parameter :: twothirds = 2.d0/3.d0
    double precision, parameter :: fac1      = -1.d0/12.d0
    double precision, parameter :: fac2      =  4.d0/3.d0
    double precision, parameter :: fac3      = -7.5d0

    integer          :: i,j,k,ndo

    allocate(  dU(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng,2))
    allocate(Unew(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng,2))

    if (ng < 6) then
       print *,'NOT ENOUGH GHOST CELLS IN ADVANCE ',ng
       stop
    end if

    ! First call to get RHS = Lap(U)
    ndo = 4

    do k = lo(3)-ndo,hi(3)+ndo
       do j = lo(2)-ndo,hi(2)+ndo
          do i = lo(1)-ndo,hi(1)+ndo

             dU(i,j,k,1) = U(i,j,k,2)

             dU(i,j,k,2) = (  fac1 * ( U(i-2,j,k,1) + U(i+2,j,k,1) + &
                                       U(i,j-2,k,1) + U(i,j+2,k,1) + &
                                       U(i,j,k-2,1) + U(i,j,k+2,1) ) &
                            + fac2 * ( U(i-1,j,k,1) + U(i+1,j,k,1) + &
                                       U(i,j-1,k,1) + U(i,j+1,k,1) + &
                                       U(i,j,k-1,1) + U(i,j,k+1,1) ) &
                            + fac3 *   U(i,j,k,1)  ) / (dx*dx)
          end do
       end do
    end do

    ! First update
    ! This Unew lives at t^{n+1}
    Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) = &
                 U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) &
         + dt * dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2)

    ! Second call to get RHS = Lap(Unew)
    ndo = 2

    do k = lo(3)-ndo,hi(3)+ndo
       do j = lo(2)-ndo,hi(2)+ndo
          do i = lo(1)-ndo,hi(1)+ndo

             dU(i,j,k,1) = Unew(i,j,k,2)

             dU(i,j,k,2) = (  fac1 * ( Unew(i-2,j,k,1) + Unew(i+2,j,k,1) + &
                                       Unew(i,j-2,k,1) + Unew(i,j+2,k,1) + &
                                       Unew(i,j,k-2,1) + Unew(i,j,k+2,1) ) &
                            + fac2 * ( Unew(i-1,j,k,1) + Unew(i+1,j,k,1) + &
                                       Unew(i,j-1,k,1) + Unew(i,j+1,k,1) + &
                                       Unew(i,j,k-1,1) + Unew(i,j,k+1,1) ) &
                            + fac3 *   Unew(i,j,k,1)  ) / (dx*dx)
          end do
       end do
    end do

    ! Second update
    ! This Unew lives at t^{n+1/2}
    Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) = &
                .75d0 *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) &
              + .25d0 * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) &
         + dt * .25d0 *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2)

    ! Third call to get RHS = Lap(Unew)
    ndo = 0

    do k = lo(3)-ndo,hi(3)+ndo
       do j = lo(2)-ndo,hi(2)+ndo
          do i = lo(1)-ndo,hi(1)+ndo

             dU(i,j,k,1) = Unew(i,j,k,2)

             dU(i,j,k,2) = (  fac1 * ( Unew(i-2,j,k,1) + Unew(i+2,j,k,1) + &
                                       Unew(i,j-2,k,1) + Unew(i,j+2,k,1) + &
                                       Unew(i,j,k-2,1) + Unew(i,j,k+2,1) ) &
                            + fac2 * ( Unew(i-1,j,k,1) + Unew(i+1,j,k,1) + &
                                       Unew(i,j-1,k,1) + Unew(i,j+1,k,1) + &
                                       Unew(i,j,k-1,1) + Unew(i,j,k+1,1) ) &
                            + fac3 *   Unew(i,j,k,1)  ) / (dx*dx)

          end do
       end do
    end do

    ! Third update
    ! This Unew lives at t^{n+1}
    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2) =        &
                third     *    U(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2)   &
              + twothirds * Unew(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2)   &
         + dt * twothirds *   dU(lo(1)-ndo:hi(1)+ndo,lo(2)-ndo:hi(2)+ndo,lo(3)-ndo:hi(3)+ndo,1:2)

    deallocate(dU,Unew)

  end subroutine advance_3d

end module advance_module