subroutine EFMED
!-----------------------------------------------------------------------------------
! 1. General Considerations                                                        !
! --------------------------                                                       !
! EFMED is a code for computing the effective wave number of a medium with         !
! randomly distributed spheroidal particles. The particles are identical and are   !
! illuminated by a vector plane wave traveling along the Z-axis of the global      !
! coordinate system (normal incidence). The T-matrix method together with the      !
! quasi-crystalline approximation is used to generate a set of homogeneous         !
! equations (the generalized Lorentz-Lorenz law):                                  !
!                                                                                !
!                         [I - n * T * (J1 + J2)] * s = 0,                         !
!                                                                                !
! where I is the identity matrix, T is the transition matrix, n is the number      !
! of particles per unit volume (n = N / V), J1 and J2 are the averaged translation !
! matrices and s is the unknown vector of the scattered field coefficients.        !
! Note that the elements of the averaged translation matrices are expressed as     !
! integrals over the zenith angle beta. For a nontrivial solution of the system of !
! homogeneous equations, the determinant must vanishes giving an equation for      !
! the effective wave number. The code computes the effective wave numbers for      !
! size parameters ranging from xmin to xmax in dx steps. For a spheroidal          !
! particles with semi-axes a and b, the size parameter is defined as               !
!                                                                                !
!                             x = k * max(a,b),                                    !
!                                                                                !
! where k is the wave number in the ambient medium. The root of the equation       !
!                                                                                !
!                   det {I - n * T * (J1 + J2)} = 0,                               !
!                                                                                !
! is searched in the complex plane using Mueller's method. Mueller's method        !
! requires an initial guess and two starting values for the effective wave         !
! number. For x = xmin, the initial guess is computed by using the first and       !
! second order approximations of the long-wavelength T-matrix method. The          !
! second and third starting values of the wave number are given by:                !
!                                                                                !
!                           K2 = K1 + delta,                                       !
!                                                                                !
! and                                                                              !
!                                                                                !
!                           K3 = K2 + delta,                                       !
!                                                                                !
! respectively, where K1 is the initial guess and delta is a parameter specified   !
! in the namelist input. The process of calculation is iterative, i.e., the wave   !
! number corresponding to the size parameter x serves as initial guess for         !
! computing the wave number corresponding to the size parameter x + dx.            !
!                                                                                !
! For axisymmetric particles with the axis of symmetry directed along the Z-axis,  !
! the transition matrix is diagonal with respect to azimuthal index. Because the   !
! non-vanishing incident field coefficients correspond to the azimuthal modes      !
! m = 1 and m = -1, only these modes are required for computing the effective      !
! wave number.                                                                     !
!                                                                                !
! The elements of the averaged translation matrix J2 are expressed in terms of     !
! the quantities:                                                                  !
!                                                                                !
!                   |inf                                                           !
!             G_n = |  [g(2Rx) - 1] * h_n(2kRx) * j_n(2Krx) x**2 dx,               !
!                   |0                                                             !
!                                                                                !
! where g is the pair distribution function, R is the radius of a sphere           !
! enclosing the particle (for spherical particles, R is the particle radius),      !
! k is the wave number in the ambient medium and h_n and j_n are the spherical     !
! Hankel and Bessel functions. For the Percus-Yevick pair distribution function,   !
! we have:                                                                         !
!                                                                                !
!                             Pi  |inf          sin(ux)                            !
!              g(2Rx) - 1 = ------|  H(u/2R) * --------- u**2 du                   !
!                           2R**2 |0              ux                               !
!                                                                                !
! where H is the Fourier transform of the total correlation function. Note that    !
! Percus-Yevick pair distribution function is the solution of the Ornstein-Zernike !
! equation for the total and direct correlation functions of two particles h(r)    !
! and d(r) under the assumption that h(r) - d(r) = y(r) - 1. For the case of       !
! hard-sphere potential, the Ornstein-Zernicke equation with Percus-Yevick         !
! approximation has a closed-form solution H. The function g(2Rx) - 1 is computed  !
! by sintransform                                                                  !
!                                                                                !
!                              Pi  |L                                              !
!              g(2Rx) - 1 = -------|  H(u/2R) * u * sin(ux) du,                    !
!                           2xR**2 |0                                              !
!                                                                                !
! while the G_n are given by                                                       !
!                                                                                !
!                   |Xmax                                                          !
!             G_n = |  [g(2Rx) - 1] * h_n(2kRx) * j_n(2Krx) x**2 dx.               !
!                   |0                                                             !
!                                                                                !
! The number of discrete points N for computing the pair distribution function     !
! by sintransform is                                                               !
!                                                                                !
!                         N = 2**pN,                                               !
!                                                                                !
! while the upper limits L and Xmax are                                            !
!                                                                                !
!                         L ~ 2**(pN - p)                                          !
!                                                                                !
! and                                                                              !
!                                                                                !
!                         Xmax ~ 2**p,                                             !
!                                                                                !
! respectively. The integers p and pN are supplied in the namelist input, and the  !
! coefficients G_n are computed by using the trapez integration method.            !
!                                                                                !
! For spherical particles with small size parameters, the effective wave numbers   !
! can be also computed by using the long-wavelength quasi-crystalline              !
! approximations with and without coherent potential.                              !
!                                                                                !
! The input data are supplied by the file "/INPUTFILES/InputEFMED.dat", while      !
! the output data are written to the file "/OUTPUTFILES/Output.dat".               !
!                                                                                !
! 2. Input Parameters                                                              !
! --------------------                                                             !
! The parameters specified in the input file "/INPUTFILES/InputEFMED.dat" are      !
! listed below.                                                                    !
!                                                                                !
! - ind_refMed (real) - refractive index of the ambient medium.                    !
!                                                                                !
! - ind_refRel (complex) - relative refractive index of the spheroidal particles   !
!   with respect to the ambient medium.                                            !
!                                                                                !
! - xmax (real) - maximum size parameter. The size parameter is defined as         !
!   x = k * max(a,b), where k is the wave number in the ambient medium, a is       !
!   the semi-axis along the axis of symmetry and b is the second half-axis.        !
!                                                                                !
! - xmin (real) - minimum size parameter.                                          !
!                                                                                !
! - dx (real) - size parameter step. This parameter MUST BE POSITIVE.              !
!                                                                                !
! - e (real) - eccentricity of the spheroidal particle. e is defined as            !
!   e = a / b, where as before, a is the semi-axis along the axis of symmetry      !
!   and b is the second half-axis. For spherical particles, set e = 1.0.           !
!                                                                                !
! - c (real) - volume concentration, c = N * Vp / V, where N is the number of      !
!   particles, Vp is the volume of the particle and V is the volume occupied by    !
!   the particles.                                                                 !
!                                                                                !
! - Nint (integer) - number of integration points on the particle surface for      !
!   computing the T matrix.                                                        !
!                                                                                !
! - RandomOrientation (logical) - if RandomOrientation = t, the spheroidal         !
!   particle is randomly oriented, otherwise the axis of symmetry is along the     !
!   Z-axis (the incident direction).                                               !
!                                                                                !
! - ComputeQCA (logical) - if ComputeQCA = t, the long-wavelength                  !
!   quasicrystalline approximations with and without coherent potential are used   !
!   to compute the effective wave number. These methods can be used for spherical  !
!   particles with small size parameter.                                           !
!                                                                                !
! - Nbeta (integer) - number of integration points for computing the elements of   !
!   the averaged translation matrices J1 and J2.                                   !
!                                                                                !
! - p, pN (integer variables) - determine the numbers of discretization points     !
!   for computing the pair distribution function by sintransform,                  !
!                                                                                !
!                                |L                                                !
!                         f(x) = |  F(u)*sin(u*x) du,                              !
!                                |0                                                !
!                                                                                !
!   The number of discrete points is N = 2**pN, L ~ Pi * 2**(pN - p), and the      !
!   upper limit for the pair-distribution function integration is Xmax ~ 2**p.     !
!   For low volume concentration we recommend to use p = 3, while for high         !
!   volume concentration we recommend to use p = 4. Here is a table giving some    !
!   approximate values of the parameters.                                          !
!                                                                                !
!                         N         L          Xmax                                !
!                                                                                !
!     p = 3, pN =  8     256       100           8                                 !
!     p = 3, pN =  9     512       200           8                                 !
!     p = 3, pN = 10    1024       400           8                                 !
!     p = 3, pN = 11    2048       800           8                                 !
!     p = 3, pN = 12    4096      1600           8                                 !
!     p = 3, pN = 13    8192      3200           8                                 !
!                                                                                !
!     p = 4, pN =  8     256        50          16                                 !
!     p = 4, pN =  9     512       100          16                                 !
!     p = 4, pN = 10    1024       200          16                                 !
!     p = 4, pN = 11    2048       400          16                                 !
!     p = 4, pN = 12    4096       800          16                                 !
!     p = 4, pN = 13    8192      1600          16                                 !
!                                                                                !
!     p = 5, pN =  8     256        25          32                                 !
!     p = 5, pN =  9     512        50          32                                 !
!     p = 5, pN = 10    1024       100          32                                 !
!     p = 5, pN = 11    2048       200          32                                 !
!     p = 5, pN = 12    4096       400          32                                 !
!     p = 5, pN = 13    8192       800          32                                 !
!                                                                                !
!  - epsX, epsY (real variables) - tolerance specifying the accuracy of root     !
!    computation.  For Mueller's method we impose a conservative criterion, i.e.,  !
!    the convergence is achieved if the iterates converge (epsX cratered) and     !
!    the residual is smaller than a given tolerance (epsY criterion).             !
!                                                                                !
! - Niter (integer) - maximum number of iterations for Mueller's method.           !
!                                                                                !
! WARNING: OUR FEELING IS THAT THERE IS AN ERROR IN THE ROUTINE FOR COMPUTING THE  !
! EFFECTIVE WAVE NUMBER OF SPHEROIDAL PARTICLES. IN THIS REGARD, WE RECOMMEND TO   !
! USE THE CODE ONLY FOR SPHERICAL PARTICLES.                                       !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: Nint, Nbeta, Niter, p, pN, ios, N
  real(O)    :: xmax, xmin, dx, e, c, wavelength, epsX, epsY, ind_refMed,           &
                lambdaMed, wavenumberMed, du, L, lmax
  complex(O) :: ind_refRel
  logical    :: RandomOrientation, ComputeQCA
! -----------------------------------------------------------------------------------
!                               Read the Input File                                 !
! -----------------------------------------------------------------------------------
  call readinputEFMED ( wavelength, ind_refMed, ind_refRel, xmax, xmin, dx, e,      &
       c, Nint, Nbeta, p, pN, epsX, epsY, Niter, RandomOrientation, ComputeQCA )
  lambdaMed     = wavelength / ind_refMed
  wavenumberMed = 2 * Pi / lambdaMed
! ----------------------------------------------------------------------------------
!                         Write Informations to Output File                        !
! ----------------------------------------------------------------------------------
  open (unit = iOutput, file = FileOutput, status = "replace")
  write (iOutput,"(/,2x,'Input Parameters of the Scattering Problem:',/)")
  write (iOutput,"(2x, a, 1pe10.3, a)")                                             &
 'refractive index of the ambient medium, ind_refMed = ', ind_refMed, ';'
  write (iOutput,"(2x, a, 1pe10.3, a)")                                             &
 'wave number in the ambient medium, wave_numberMed  = ', wavenumberMed, ';'
  write (iOutput,"(2x, a, 1pe10.3, ',', 1pe10.3, a)")                               &
 'relative refractive index of the particle, ind_refRel = (', ind_refRel, ');'
  write (iOutput,"(2x,'volume concentration,   c    = ',1pe10.3,';')") c
  write (iOutput,"(2x,'maximum size parameter, xmax = ',1pe10.3,';')") xmax
  write (iOutput,"(2x,'minimum size parameter, xmin = ',1pe10.3,';')") xmin
  write (iOutput,"(2x,'size parameter step,    dx   = ',1pe10.3,';')") dx
  write (iOutput,"(2x,'spheroid eccentricity,  e    = ',1pe10.3,';')") e
  write (iOutput,"(2x, a, i3,';')")                                                 &
 'number of integration points on the particle surface, Nint = ', Nint
  if (RandomOrientation) then
    write (iOutput,"(2x,'randomly oriented spheroidal particles;')")
  else
    write (iOutput,"(2x,'particles in fixed orientation;')")
  end if
  N    = 2**pN
  du   = Pi / 2**p
  L    = real(N - 1,O) * du
  lmax = real(N - 1,O) * Pi / real(N,O) / du
  write (iOutput,"(2x, a, i2, a, i2, a)")                                           &
 'parameters controlling the discretization process, p = ', p, ', pN = ', pN, ';'
  write (iOutput,"(2x,'number of discrete points, N = ',i6,';')") N
  write (iOutput,"(2x, a, 1pe10.3, a)")                                             &
 'upper limit for sintransform integration, L = ', L, ';'
  write (iOutput,"(2x, a, 1pe10.3, a)")                                             &
 'upper limit for pair-distribution function integration, Xmax = ', lmax, ';'
  write (iOutput,"(2x, a, i6, a)")                                                  &
 'maximum number of iterations for Mueller''s method, Niter = ', Niter, ';'
  write (iOutput,"(2x, a, 1pe10.3, a, 1pe10.3, a)")                                 &
 'tolerences controlling Mueller''s iterations, epsX = ', epsX, ', epsY = ', epsY, ';'
!-----------------------------------------------------------------------------------
!                                   Main                                           !
!-----------------------------------------------------------------------------------
  print "(/,2x,'Effective Wavenumber of a Medium with Spheroidal Particles',/)"
  call IterativeSpheroidMullerSolver ( wavenumberMED, ind_refRel, xmax, xmin, dx,   &
       e, c, Nint, Nbeta, p, pN, Niter, epsX, epsY, RandomOrientation, ComputeQCA )
  close (unit = iOutput)
end subroutine EFMED
!***********************************************************************************
subroutine readinputEFMED ( wavelength, ind_refMed, ind_refRel, xmax, xmin, dx, e,  &
           c, Nint, Nbeta, p, pN, epsX, epsY, Niter, RandomOrientation, ComputeQCA )
  use parameters
  use derived_parameters
  implicit none
  integer       :: Nint, Nbeta, Niter, p, pN, ios
  real(O)       :: wavelength, xmax, xmin, dx, e, c, epsX, epsY, ind_refMed
  complex(O)    :: ind_refRel
  character(80) :: string
  logical       :: RandomOrientation, ComputeQCA, XFindPar
!
  call DrvParameters
  open (unit = iInputEFMED, file = FileInputEFMED, status = "old", position = "rewind")
  wavelength = 0.2_O * Pi
  ind_refMed = 1._O
  ind_refRel = (1.668_O,0.510_O)
  string     = 'OptProp'
  if (XFindPar (iInputEFMED, string)) then
    read (iInputEFMED, *, iostat = ios) wavelength
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable wavelength;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) ind_refMed
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable ind_refMed;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) ind_refRel
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable ind_refRel;')"
      stop
    end if
  else
    print "(/,2x,'Group name OptProp not found;')"
    stop
  end if
!
  xmax = 0.5_O
  xmin = 0.1_O
  dx   = 0.1_O
  e    = 1.0_O
  c    = 0.1_O
  Nint = 60
  RandomOrientation = .true.
  ComputeQCA        = .true.
  string = 'TmatPart'
  if (XFindPar (iInputEFMED, string)) then
    read (iInputEFMED, *, iostat = ios) xmax
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable xmax;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) xmin
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable xmin;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) dx
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable dx;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) e
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable e;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) c
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable c;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) Nint
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable Nint;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) RandomOrientation
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable RandomOrientation;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) ComputeQCA
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable ComputeQCA;')"
      stop
    end if
  else
    print "(/,2x,'Group name TmatPart not found;')"
    stop
  end if
  if (e == 1._O) then
    RandomOrientation = .false.
  else
    ComputeQCA = .false.
  end if
!
  Nbeta = 180
  p  = 5
  pN = 10
  epsX   = 1.e-6_O
  epsY   = 1.e-6_O
  Niter  = 1000
  string = 'AlgProp'
  if (XFindPar (iInputEFMED, string)) then
    read (iInputEFMED, *, iostat = ios) Nbeta
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable Nbeta;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) p
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable p;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) pN
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable pN;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) epsX
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable epsX;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) epsY
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable epsY;')"
      stop
    end if
    read (iInputEFMED, *, iostat = ios) Niter
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable Niter;')"
      stop
    end if
  else
    print "(/,2x,'Group name AlgProp not found;')"
    stop
  end if
  close (unit = iInputEFMED)
end subroutine readinputEFMED
!***********************************************************************************
subroutine IterativeSpheroidMullerSolver ( wavenumberMED, ind_refRel, xmax, xmin,   &
           dx, e, c, Nint, Nbeta, p, pN, Niter, epsX, epsY, RandomOrientation,      &
           ComputeQCA )
  use parameters
  implicit none
  integer    :: Nint, Nbeta, p, pN, Niter
  real(O)    :: xmax, xmin, dx, e, c, epsX, epsY, wavenumberMed
  complex(O) :: ind_refRel
  logical    :: RandomOrientation, ComputeQCA
!
  integer    :: Nx, ix, Nrank
  real(O)    :: Nxreal, x, SemiAxisA, SemiAxisB, a, x3
  complex(O) :: kX, wavenumberEFMED, epsRel, tamp, fct
  logical    :: sphere, Conv
!
  sphere = .false.
  if ( e == 1._O ) sphere = .true.
  if ( xmin > xmax ) then
    Nx = 1
  else
    Nxreal = ( xmax - xmin ) / dx
    Nx     = int(Nxreal)
    if (Nx + 0.1_O > Nxreal) then
      Nx = Nx + 1
    else
      Nx = Nx + 2
    end if
  end if
  kX = cmplx(wavenumberMED,0.0,O)
  print "(2x,'Iterative calculation over the size parameter:')"
! ----------------------------------------------------------------------------------
!                              T-Matrix Method                                     !
! ----------------------------------------------------------------------------------
  write (iOutput,"(/)")
  write (iOutput,"(2x,'Results',/)")
  write (iOutput,"(2x,'T-Matrix Method')")
  write (iOutput,"(2x,'size parameter          effective wave number',/)")
  do ix = 1, Nx
    if (ix < Nx) then
      x = xmin + (ix - 1) * dx
    else
      x = xmax
    end if
    if (e >= 1._O) then
      SemiAxisA = x / wavenumberMED
      SemiAxisB = SemiAxisA / e
    else
      SemiAxisB = x / wavenumberMED
      SemiAxisA = SemiAxisB * e
    end if
    Nrank = int(x + 4.05_O * x**0.33_O + 2._O)
    if (Nrank < 4) Nrank = Nrank + 4
    a = max (SemiAxisA, SemiAxisB)
    print "(2x,'iteration      = ', i3, ';')", ix
    print "(2x,'size parameter =', 1pe13.4, ';')", x
    if ( ix == 1) then
      call InitialGuessSpheroid (wavenumberMED, ind_refRel, a, SemiAxisA,           &
           SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, epsX, epsY,        &
           Niter, Conv, kX)
      if (Conv) then
        print "(2x,'initial guess  = (',1pe13.4,',',1pe13.4,'   );')", kX
      else
        print "(/,2x,'convergence is not achieved at the initial guess;')"
        print "(  2x, a)",                                                          &
       'the tolerances epsX/epsY, or the iteration number Niter are too low;'
        stop
      end if
    end if
    wavenumberEFMED = kX
    call MullerSpheroid (wavenumberEFMED, wavenumberMED, ind_refRel, a, SemiAxisA,  &
         SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, Niter, &
         epsX, epsY, Conv, kX)
    if (Conv) then
      print "(2x,'initial  effective wave number = (',1pe13.4,',',1pe13.4,'   );')",  &
	      wavenumberEFMED
      print "(2x,'computed effective wave number = (',1pe13.4,',',1pe13.4,'   );',/)",&
              kX
      write (iOutput,"(2x, 1pe13.4, '      (',1pe13.4,',',1pe13.4,'   )')") x, kX
     !write (iOutput,"(2x, 1pe13.4, 2x, 1pe13.4, 2x, 1pe13.4)") x, wavenumberMED/real(kX), &
     !	     2.d0*aimag(kX)/real(kX)
    else
      print "(/,2x,'convergence is not achieved;')"
      print "(  2x, a)",                                                            &
     'the tolerances epsX/epsY, or the iteration number Niter are too low;'
      stop
    end if
  end do
  if (sphere .and. ComputeQCA) then
    write (iOutput,"(/,2x,'QCA and QCA-CP')")
    write (iOutput,"(2x, a,/)")                                                     &
   'size parameter         effective wave number QCA          effective wave number QCA-CP'
    epsRel = ind_refRel**2
    tamp   = (epsRel - 1._O) / (epsRel + 2._O)
    do ix = 1, Nx
      if (ix < Nx) then
        x = xmin + (ix - 1) * dx
      else
        x = xmax
      end if
      a = x / wavenumberMED
!     ------------------------------------------------------------------------------
!                 Long-Wavelength Quasicrystalline Approximation                   !
!     ------------------------------------------------------------------------------
      x3  = x**3
      fct = 3._O * c * tamp  / (1._O - c * tamp)
      fct = fct * (1._O + im * 2._O * x3 * tamp * (1._O - c)**4 /                   &
          ((1._O - c * tamp) * (1._O + 2._O * c)**2 * 3._O))
      wavenumberEFMED = wavenumberMed * sqrt(1._O + fct)
!     ------------------------------------------------------------------------------
!         Long-Wavelength Quasicrystalline Approximation with Coherent Potential   !
!     ------------------------------------------------------------------------------
      call MullerQCACP (wavenumberEFMED, wavenumberMED, ind_refRel, a, c, Niter,    &
           epsX, epsY, Conv, kX)
      if (Conv) then
        write (iOutput,"(2x,1pe13.4,a,1pe13.4,',',1pe13.4,a,1pe13.4,',',1pe13.4,a)")&
               x,'      (', wavenumberEFMED, '   )     (', kX, '   )'
      else
        print "(/,2x,'convergence is not achieved for QCA-CP;')"
        print "(  2x, a)",                                                          &
       'the tolerances epsX/epsY, or the iteration number Niter are too low;'
        stop
      end if
    end do
  end if
end subroutine IterativeSpheroidMullerSolver
!***********************************************************************************
subroutine MullerSpheroid (wavenumberEFMED, wavenumberMED, ind_refRel, a, SemiAxisA,&
           SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN,      &
           Niter, epsX, epsY, Conv, x)
  use parameters
  implicit none
  integer    :: Nrank, Nint, Nbeta, p, pN, Niter
  real(O)    :: a, SemiAxisA, SemiAxisB, c, epsX, epsY, wavenumberMed
  complex(O) :: wavenumberEFMED, ind_refRel, x
  logical    :: sphere, RandomOrientation, Conv
!
  integer    :: iter
  real(O)    :: deltaX
  complex(O) :: delta, x0, x1, x2, P0, P1, P2, s, t, u, den, den1, d, q
!
  delta = 0.01_O * wavenumberEFMED
  x0 = wavenumberEFMED
  x1 = x0 + delta
  x2 = x1 + delta
  call DeterminantEFMEDSpheroid (x0, wavenumberMED, ind_refRel, a, SemiAxisA,       &
       SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, P0)
  call DeterminantEFMEDSpheroid (x1, wavenumberMED, ind_refRel, a, SemiAxisA,       &
       SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, P1)
  call DeterminantEFMEDSpheroid (x2, wavenumberMED, ind_refRel, a, SemiAxisA,       &
       SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, P2)
  iter = 0
  Conv = .false.
  print "(2x,'iteration summary of Mueller''s method:')"
  print "(2x,'determinants at starting points:')"
  print "(2x,'                  x0              x1              x2')"
  print "(2x,'determinant ', 1pe12.3, 4x, 1pe12.3, 4x, 1pe12.3)", abs(P0), abs(P1), abs(P2)
  print "(2x,'iteration',1x,'|x(n) - x(n-1)|',6x,'|det(x(n))|')"
  do while ((iter < Niter) .and. (.not.Conv))
    iter = iter + 1
    q = (x2 - x1) / (x1 - x0)
    s = q * P2 - q * (1._O + q) * P1 + q**2 * P0
    t = (2._O * q + 1._O) * P2 - (1._O + q)**2 * P1 + q**2 * P0
    u = (1._O + q) * P2
    d = sqrt(t**2 - 4._O * s * u)
    den  = t + d
    den1 = t - d
    if (abs(den) < abs(den1)) den = den1
    x = x2 - (x2 - x1) * 2._O * u / den
    deltaX = abs(x - x2)
    if (abs(x - x1) < abs(x - x0)) then
      s  = x1
      x1 = x0
      x0 = s
      t  = P1
      P1 = P0
      P0 = t
    else if (abs(x - x1) > abs(x - x2)) then
      s  = x2
      x2 = x1
      x1 = s
      t  = P2
      P2 = P1
      P1 = t
    end if
    x2 = x
    call DeterminantEFMEDSpheroid (x2, wavenumberMED, ind_refRel, a, SemiAxisA,     &
         SemiAxisB, sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, P2)
    print "(5x,i3,4x,1pe12.3,7x,1pe12.3)", iter, deltaX, abs(P2)
    if ((deltaX < epsX) .and. (abs(P2) < epsY)) Conv = .true.
  end do
  x = x2
  if (imag(x) < 0._O) x = wavenumberEFMED
end subroutine MullerSpheroid
!***********************************************************************************
subroutine InitialGuessSpheroid (k, ind_refRel, a, SemiAxisA, SemiAxisB, sphere,    &
           RandomOrientation, c, Nrank, Nint, epsX, epsY, Niter, Conv, kX)
  use parameters
  implicit none
  integer    :: Nrank, Nint, Niter
  real(O)    :: a, SemiAxisA, SemiAxisB, c, k, epsX, epsY
  complex(O) :: kX, ind_refRel
  logical    :: sphere, RandomOrientation, Conv
!
  integer    :: iter
  real(O)    :: deltaX
  complex(O) :: delta, T11, T22, T12, T21, x, alpha, x0, x1, x2, P0, P1, P2, s, v,  &
                u, den, den1, d, q
  complex(O),allocatable :: T(:,:), tv(:), tv11(:), tv12(:), tv21(:), tv22(:)
! --- first order approximation ---
  if (.not. sphere) then
    if (.not. RandomOrientation) then
      allocate (T(2*Nrank,2*Nrank))
      call TmatrixSpheroid (k, ind_refRel, SemiAxisA, SemiAxisB, Nrank, Nint, T)
      T11 = T(1,1)
      T22 = T(Nrank+1,Nrank+1)
      T12 = T(1,Nrank+1)
      T21 = T(Nrank+1,1)
      deallocate (T)
    else
      allocate (tv11(Nrank), tv12(Nrank), tv21(Nrank), tv22(Nrank))
      call AverageTmatrixSpheroid (k, ind_refRel, SemiAxisA, SemiAxisB, Nrank,      &
           Nint, tv11, tv12, tv21, tv22)
      T11 = tv11(1)
      T22 = tv22(1)
      T12 = tv12(1)
      T21 = tv21(1)
      deallocate (tv11, tv12, tv21, tv22)
    end if
  else
    allocate (tv(2*Nrank))
    call coefficients_fg_m (k, SemiAxisA, ind_refRel, 1, Nrank, Nrank, tv)
    T11 = tv(1)
    T22 = tv(Nrank+1)
    T12 = 0._O
    T21 = 0._O
    deallocate (tv)
  end if
  x     = cmplx(k * a,0.0,O)
  alpha = x * x * x * ( (1._O - c)**4 / (1._O + 2._O * c)**2 - 1._O / T22 )
  kX    = k * sqrt ( (2._O * alpha + 6._O * im * c) / (2._O * alpha - 3._O * im * c) )
  if ( imag(kX) < 0._O ) kX = - kX
! --- second order approximation ---
  delta = 0.01_O * kX
  x0 = kX
  x1 = x0 + delta
  x2 = x1 + delta
  call DeterminantLWLSpheroid (x0, k, a, c, T11, T22, T12, T21, P0)
  call DeterminantLWLSpheroid (x1, k, a, c, T11, T22, T12, T21, P1)
  call DeterminantLWLSpheroid (x2, k, a, c, T11, T22, T12, T21, P2)
  iter = 0
  Conv = .false.
  do while ((iter < Niter) .and. (.not. Conv))
    iter = iter + 1
    q = (x2 - x1) / (x1 - x0)
    s = q * P2 - q * (1._O + q) * P1 + q**2 * P0
    v = (2._O * q + 1._O) * P2 - (1._O + q)**2 * P1 + q**2 * P0
    u = (1._O + q) * P2
    d = sqrt(v**2 - 4._O * s * u)
    den  = v + d
    den1 = v - d
    if (abs(den) < abs(den1)) den = den1
    x = x2 - (x2 - x1) * 2._O * u / den
    deltaX = abs(x - x2)
    if (abs(x - x1) < abs(x - x0)) then
      s  = x1
      x1 = x0
      x0 = s
      v  = P1
      P1 = P0
      P0 = v
    else if (abs(x - x1) > abs(x - x2)) then
      s  = x2
      x2 = x1
      x1 = s
      v  = P2
      P2 = P1
      P1 = v
    end if
    x2 = x
    call DeterminantLWLSpheroid (x2, k, a, c, T11, T22, T12, T21, P2)
    if ((deltaX < epsX) .and. (abs(P2) < epsY)) Conv = .true.
  end do
  if (imag(x2) >= 0._O) kX  = x2
end subroutine InitialGuessSpheroid
!***********************************************************************************
subroutine DeterminantEFMEDSpheroid (kX, k, ind_refRel, a, SemiAxisA, SemiAxisB,    &
           sphere, RandomOrientation, c, Nrank, Nint, Nbeta, p, pN, Pv)
  use parameters
  implicit none
  integer    :: Nrank, Nint, Nbeta, p, pN
  real(O)    :: a, SemiAxisA, SemiAxisB,c, k
  complex(O) :: kX, ind_refRel, Pv
  logical    :: sphere, RandomOrientation
!
  integer    :: i, j
  complex(O) :: fact, det
  complex(O),allocatable :: AB(:,:), T(:,:), tv(:), tv11(:), tv12(:), tv21(:),      &
                            tv22(:)
!
  allocate (AB(2*Nrank,2*Nrank), T(2*Nrank,2*Nrank))
  call matrix_translationAB_mn_m1n1_EFMED (k, kX, a, c, Nrank, Nbeta, p, pN,        &
       AB, Nrank, Nrank)
  if ( .not. sphere) then
    if (.not. RandomOrientation) then
      call TmatrixSpheroid (k, ind_refRel, SemiAxisA, SemiAxisB, Nrank, Nint, T)
      call product_matrices (2*Nrank, 2*Nrank, 2*Nrank, T, 2*Nrank, 2*Nrank,        &
           AB, 2*Nrank, 2*Nrank)
    else
      allocate (tv11(Nrank), tv12(Nrank), tv21(Nrank), tv22(Nrank))
      call AverageTmatrixSpheroid (k, ind_refRel, SemiAxisA, SemiAxisB, Nrank,      &
           Nint, tv11, tv12, tv21, tv22)
      call product_AverageTmatrix (Nrank, tv11, tv12, tv21, tv22, Nrank,            &
           AB, 2*Nrank, 2*Nrank, T, 2*Nrank, 2*Nrank)
      deallocate (tv11, tv12, tv21, tv22)
    end if
  else
    allocate (tv(2*Nrank))
    call coefficients_fg_m (k, SemiAxisA, ind_refRel, 1, Nrank, Nrank, tv)
    call product_matrix_vector1 (2*Nrank, 2*Nrank, tv, AB, 2*Nrank, 2*Nrank,        &
         T, 2*Nrank, 2*Nrank)
    deallocate (tv)
  end if
  fact = 24._O * c / ((k * a)**2 - (kX * a)**2)
  do i = 1, 2*Nrank
    do j = 1, 2*Nrank
      if (i == j) then
        T(i,j) = one - fact * T(i,j)
      else
        T(i,j) = - fact * T(i,j)
      end if
    end do
  end do
  call determinant (T, 2*Nrank, 2*Nrank, 2*Nrank, det)
  Pv = det
  deallocate (AB, T)
end subroutine DeterminantEFMEDSpheroid
!***********************************************************************************
subroutine DeterminantLWLSpheroid (kX, k, r, c, T11, T22, T12, T21, P)
  use parameters
  implicit none
  real(O)    :: r, c, k
  complex(O) :: kX, T11, T22, T12, T21, P
!
  complex(O) :: x, xx, x2, ci, JH0, JH1, JH2, A, B, a11, a12, a21, a22
!
  x   = cmplx(k * r,0.0,O)
  xx  = kX * r
  x2  = x**2 - xx**2
  ci  = 3._O * im * c
  JH0 = ci / x / x2 + (1._O - c)**4 / (1._O + 2._O * c)**2
  JH1 = ci * xx / x / x / x2
  JH2 = ci * xx**2 / x / x / x / x2
  A   = JH0 + 0.5_O * JH2
  B   = 1.5_O * JH1
  a11 = one - ( T11 * A + T12 * B )
  a12 = - ( T11 * B + T12 * A )
  a21 = - ( T21 * A + T22 * B )
  a22 = one - ( T21 * B + T22 * A )
  P   = a11 * a22 - a12 * a21
end subroutine DeterminantLWLSpheroid
!***********************************************************************************
subroutine TmatrixSpheroid (k, ind_ref, SemiAxisA, SemiAxisB, Nrank, Nint, T)
  use parameters
  implicit none
  integer       :: Nrank, Nint
  real(O)       :: k, SemiAxisA, SemiAxisB
  complex(O)    :: ind_ref, T(2*Nrank,2*Nrank)
!
  integer       :: Nmax, TypeGeom, Nsurf, Nparam, Nface, i, j, m
  real(O)       :: rp(2,NfacePD), np(2,NfacePD), area(NfacePD), kb
  logical       :: FileGeom, miror, perfectcond, DS, chiral
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: surf(:), zRe(:), zIm(:), paramG(:,:), pondereG(:,:)
  complex(O),allocatable :: a(:,:)
!
  m      = 1
  Nmax   = Nrank
  DS     = .false.
  chiral = .false.
  kb     =  0.1
  miror  = .false.
  perfectcond = .false.
  FileGeom = .false.
  TypeGeom = 1
  Nsurf    = 2
  allocate (surf(Nsurf))
  surf(1) = SemiAxisA
  surf(2) = SemiAxisB
  Nparam  = 1
  Nface   = 1
  do i = 1, NfacePD
    do j = 1, 2
      rp(j,i) = 0._O
      np(j,i) = 0._O
    end do
    area(i) = 0._O
  end do
  allocate (zRe(Nrank), zIm(Nrank))
  do i = 1, Nrank
    zRe(i)  = 0._O
    zIm(i)  = 0._O
  end do
  allocate (a(2*Nrank,2*Nrank))
  allocate (paramG(Nparam,Nint), pondereG(Nparam,Nint), Nintparam(Nparam))
  call interpolation_listAXSYM (TypeGeom, Nsurf, surf, Nint, Nparam,                &
       Nintparam, paramG, pondereG, miror)
  call matrix_Q_m (FileGeom, TypeGeom, 3, 1, k, ind_ref, Nsurf, surf, rp, np,       &
       area, Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam, paramG,      &
       pondereG, miror, perfectcond, DS, chiral, kb, a, Nrank, Nrank)
  call matrix_Q_m (FileGeom, TypeGeom, 1, 1, k, ind_ref, Nsurf, surf, rp, np,       &
       area, Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam, paramG,      &
       pondereG, miror, perfectcond, DS, chiral, kb, T, Nrank, Nrank)
  call LU_SYSTEM (a, 2*Nrank, 2*Nrank, T, 2*Nrank, 2*Nrank, 2*Nmax)
  deallocate (a, surf, zRe, zIm, paramG, pondereG, Nintparam)
end subroutine TMatrixSpheroid
!***********************************************************************************
subroutine AverageTmatrixSpheroid (k, ind_ref, SemiAxisA, SemiAxisB, Nrank, Nint,   &
           tv11, tv12, tv21, tv22)
  use parameters
  implicit none
  integer       :: Nrank, Nint
  real(O)       :: k, SemiAxisA, SemiAxisB
  complex(O)    :: ind_ref, tv11(Nrank), tv12(Nrank), tv21(Nrank), tv22(Nrank)
!
  integer       :: Nmax, TypeGeom, Nsurf, Nparam, Nface, i, j, m, n, kn
  real(O)       :: rp(2,NfacePD), np(2,NfacePD), area(NfacePD), kb, fact
  logical       :: FileGeom, miror, perfectcond, DS, chiral
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: surf(:), zRe(:), zIm(:), paramG(:,:), pondereG(:,:)
  complex(O),allocatable :: a(:,:), T(:,:)
!
  DS     = .false.
  chiral = .false.
  kb     =  0.1
  miror  = .false.
  perfectcond = .false.
  FileGeom = .false.
  TypeGeom = 1
  Nsurf    = 2
  allocate (surf(Nsurf))
  surf(1) = SemiAxisA
  surf(2) = SemiAxisB
  Nparam  = 1
  Nface   = 1
  do i = 1, NfacePD
    do j = 1, 2
      rp(j,i) = 0._O
      np(j,i) = 0._O
    end do
    area(i) = 0._O
  end do
  allocate (zRe(Nrank), zIm(Nrank))
  do i = 1, Nrank
    zRe(i)  = 0._O
    zIm(i)  = 0._O
  end do
  allocate (a(2*Nrank,2*Nrank), T(2*Nrank,2*Nrank))
  allocate (paramG(Nparam,Nint), pondereG(Nparam,Nint), Nintparam(Nparam))
  call interpolation_listAXSYM (TypeGeom, Nsurf, surf, Nint, Nparam,                &
       Nintparam, paramG, pondereG, miror)
  do n = 1, Nrank
    tv11(n) = zero
    tv12(n) = zero
    tv21(n) = zero
    tv22(n) = zero
  end do
  do m = 0, Nrank
    if (m == 0) then
      Nmax = Nrank
    else
      Nmax = Nrank - m + 1
    end if
    call matrix_Q_m (FileGeom, TypeGeom, 3, 1, k, ind_ref, Nsurf, surf, rp, np,     &
         area, Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam, paramG,    &
         pondereG, miror, perfectcond, DS, chiral, kb, a, Nrank, Nrank)
    call matrix_Q_m (FileGeom, TypeGeom, 1, 1, k, ind_ref, Nsurf, surf, rp, np,     &
         area, Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam, paramG,    &
         pondereG, miror, perfectcond, DS, chiral, kb, T, Nrank, Nrank)
    call LU_SYSTEM (a, 2*Nrank, 2*Nrank, T, 2*Nrank, 2*Nrank, 2*Nmax)
    do kn = 1, Nmax
      if (m == 0) then
        n    = kn
        fact = 1._O
      else
        n    = m + kn - 1
        fact = 2._O
      end if
      tv11(n) = tv11(n) + fact * T(kn,kn)
      tv12(n) = tv12(n) + fact * T(kn,kn+Nmax)
      tv21(n) = tv21(n) + fact * T(kn+Nmax,kn)
      tv22(n) = tv22(n) + fact * T(kn+Nmax,kn+Nmax)
    end do
  end do
  do n = 1, Nrank
    fact    = 1._O / (2._O * n + 1._O)
    tv11(n) = fact * tv11(n)
    tv12(n) = fact * tv12(n)
    tv21(n) = fact * tv21(n)
    tv22(n) = fact * tv22(n)
  end do
  deallocate (a, T, surf, zRe, zIm, paramG, pondereG, Nintparam)
end subroutine AverageTMatrixSpheroid
!***********************************************************************************
subroutine matrix_translationAB_mn_m1n1_EFMED (wavenumber, wavenumberX, a, c, Nrank,&
           Nbeta, pow, powN, AB, NP, MP)
  use parameters
  implicit none
  integer    :: Nrank, Nbeta, pow, powN, NP, MP
  real(O)    :: a, c, wavenumber
  complex(O) :: wavenumberX, AB(2*NP,2*MP)
!
  integer    :: Nsup, n, n1, n2, pint
  real(O)    :: abeta, bbeta, beta, f, nn1
  complex(O) :: ka, kaX, sum, Fn2, fact, nm, hder, jder, fpp, ftt, fpt, ftp
  real(O),allocatable    :: bt(:), wt(:), Pn(:), dPn(:), pin(:), taun(:),           &
                            Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: j(:), jd(:), h(:), hd(:), Fn2C(:)
!
  Nsup = 4 * Nrank ! we can use a lower limit for summation, i.e., Nsup = 2*Nrank;
  do n1 = 1, 2*Nrank
    do n = 1, 2*Nrank
      AB(n1,n) = zero
    end do
  end do
  allocate (j(0:Nsup+1), jd(0:Nsup+1), h(0:Nsup+1), hd(0:Nsup+1))
  allocate (bt(Nbeta), wt(Nbeta))
  allocate (Pn(0:Nsup), dPn(0:Nsup), pin(0:Nsup), taun(0:Nsup))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  ka  = cmplx(2._O * wavenumber * a,0.0,O)
  kaX = 2._O * wavenumberX * a
  call besel_h (ka, Nsup + 1, h, hd)
  call besel_j (kaX, Nsup + 1, j, jd)
  allocate (Fn2C(0:Nsup))
  call Fn2Cor (wavenumber, wavenumberX, a, c, pow, powN, Nsup, Fn2C)
  abeta = 0._O
  bbeta = Pi
  call Gauss_Legendre (abeta, bbeta, Nbeta, wt, bt)
  do pint = 1, Nbeta
    beta = bt(pint)
    call Leg_normalized (beta, 0, Nsup, Pn, dPn, pin, taun)
    sum = zero
    do n2 = 0, Nsup
      hder = n2 * h(n2) / ka - h(n2+1)
      jder = n2 * j(n2) / kaX - j(n2+1)
      Fn2  = 0.5_O * (ka * hder * j(n2) - kaX * jder * h(n2))
      Fn2  = Fn2 + Fn2C(n2)
      f = (- 1._O)**n2 * sqrt(real(2 * n2 + 1,O) / 2._O)
      sum = sum + f * Fn2 * Pn(n2)
    end do
    fact = sum * wt(pint) * sin(beta)
    call Leg_normalized (beta, 1, Nrank, Pnm, dPnm, pinm, taunm)
    do n = 1, Nrank
      do n1 = 1, Nrank
        nn1 = real(n * (n + 1) * n1 * (n1 + 1),O)
        nm  = im**(n1 - n) * fact / sqrt(nn1)
        fpp = pinm(n)  * pinm(n1)  * nm
        ftt = taunm(n) * taunm(n1) * nm
        fpt = pinm(n)  * taunm(n1) * nm
        ftp = taunm(n) * pinm(n1)  * nm
        AB(n,n1)       = AB(n,n1) + (fpp + ftt)
		AB(n,n1+Nrank) = AB(n,n1+Nrank) - (fpt + ftp)
      end do
    end do
  end do
  do n = 1, Nrank
    do n1 = 1, Nrank
      AB(n+Nrank,n1)       = AB(n,n1+Nrank)
      AB(n+Nrank,n1+Nrank) = AB(n,n1)
     end do
  end do
  deallocate (j, jd, h, hd, bt, wt, Pn, dPn, pin, taun, Pnm, dPnm, pinm,            &
              taunm, Fn2C)
end subroutine matrix_translationAB_mn_m1n1_EFMED
!***********************************************************************************
subroutine MullerQCACP (wavenumberEFMED, wavenumberMED, ind_refRel, a, c, Niter,    &
           epsX, epsY, Conv, kX)
  use parameters
  implicit none
  integer    :: Niter
  real(O)    :: a, c, epsX, epsY, wavenumberMed
  complex(O) :: wavenumberEFMED, ind_refRel, kX
  logical    :: Conv
!
  integer    :: iter
  real(O)    :: deltaX
  complex(O) :: delta, x0, x1, x2, x, P0, P1, P2, s, t, u, den, den1, d, q
!
  delta = 0.01_O * wavenumberEFMED
  x0 = wavenumberEFMED
  x1 = x0 + delta
  x2 = x1 + delta
  call FuncQCACP (x0, wavenumberMED, ind_refRel, a, c, P0)
  call FuncQCACP (x1, wavenumberMED, ind_refRel, a, c, P1)
  call FuncQCACP (x2, wavenumberMED, ind_refRel, a, c, P2)
  iter = 0
  Conv = .false.
  do while ((iter < Niter) .and. (.not.Conv))
    iter = iter + 1
    q = (x2 - x1) / (x1 - x0)
    s = q * P2 - q * (1._O + q) * P1 + q**2 * P0
    t = (2._O * q + 1._O) * P2 - (1._O + q)**2 * P1 + q**2 * P0
    u = (1._O + q) * P2
    d = sqrt(t**2 - 4._O * s * u)
    den  = t + d
    den1 = t - d
    if (abs(den) < abs(den1)) den = den1
    x = x2 - (x2 - x1) * 2._O * u / den
    deltaX = abs(x - x2)
    if (abs(x - x1) < abs(x - x0)) then
      s  = x1
      x1 = x0
      x0 = s
      t  = P1
      P1 = P0
      P0 = t
    else if (abs(x - x1) > abs(x - x2)) then
      s  = x2
      x2 = x1
      x1 = s
      t  = P2
      P2 = P1
      P1 = t
    end if
    x2 = x
    call FuncQCACP (x2, wavenumberMED, ind_refRel, a, c, P2)
    if ((deltaX < epsX) .and. (abs(P2) < epsY)) Conv = .true.
  end do
  if (imag(x2) >= 0._O) then
    kX = x2
  else
    kX = wavenumberEFMED
  end if
end subroutine MullerQCACP
!***********************************************************************************
subroutine FuncQCACP (kX, k, ind_refRel, a, c, PQCA)
  use parameters
  implicit none
  real(O)    :: a, c, k
  complex(O) :: kX, ind_refRel, PQCA
!
  complex(O) :: ks, k2, ka3, dk, fct
!
  ks  = k * ind_refRel
  k2  = ks * ks - k * k
  ka3 = k2 * kX * a**3
  dk  = k2 / (3._O * kX * kX)
  fct = c * k2 / (1._O + dk * (1._O - c))
  fct = fct * (1._O + im * 2._O * ka3 * (1._O - c)**4 /                             &
       (9._O * (1._O + dk * (1._O - c)) * (1._O + 2._O * c)**2))
  PQCA = fct + k**2 - kX**2
end subroutine FuncQCACP
!***********************************************************************************
subroutine Fn2Cor (wavenumber, wavenumberX, a, c, p, pN, Nsup, Fn2C)
  use parameters
  implicit none
  integer    :: p, pN, Nsup
  real(O)    :: a, c, wavenumber
  complex(O) :: wavenumberX, Fn2C(0:Nsup)
!
  integer    :: N, kmin, k, n2
  real(O)    :: dx, xl, gPY, w
  complex(O) :: sum, ka, kaX
  real(O),allocatable    :: x(:), G(:)
  complex(O),allocatable :: j(:), jd(:), h(:), hd(:)
!
  N = 2**pN
  allocate (x(N), G(N))
  allocate (j(0:Nsup), jd(0:Nsup), h(0:Nsup), hd(0:Nsup))
  call PYVct (c, p, N, x, G, kmin)
  dx = 1._O / 2**(pN - p)
  do n2 = 0, Nsup
    sum = zero
    do k = kmin, N
      if (k == kmin .or. k == N) then
        w = 0.5_O * dx
      else
        w = dx
      end if
      xl  = x(k)
      gPY = G(k)
      ka  = cmplx(2._O * wavenumber * a * xl,0.0,O)
      kaX = 2._O * wavenumberX * a * xl
      call besel_h (ka, Nsup, h, hd)
      call besel_j (kaX, Nsup, j, jd)
      sum = sum + (gPY - 1._O) * h(n2) * j(n2) * xl * xl * w
    end do
    Fn2C(n2) = 2._O * ((wavenumber * a)**2 - (wavenumberX * a)**2) * sum
  end do
  deallocate (x, G, j, jd, h, hd)
end
!***********************************************************************************
subroutine PYVct (c, p, N, x, G, kmin)
  use parameters
  implicit none
  integer :: p, N, kmin
  real(O) :: c, x(N), G(N)
!
  integer :: j, k
  real(O) :: Nr, N1r, L, du, uj, dx, f, max
!
  Nr  = real(N,O)
  N1r = Nr - 1._O
  L   = Pi * N1r / 2**p
  du  = L / N1r
  do j = 1, N
    uj   = real(j - 1,O) * du
    G(j) = f(c,uj) * du
  end do
  call SINFT (G, N)
  dx = Pi / Nr / du
  do k = 1, N
    x(k) = real(k - 1,O) * dx
    if (x(k) >= 1._O) then
      G(k) = 1._O + G(k) / x(k)
    else
      G(k) = 0._O
    end if
  end do
! --- compute kmin for which the maximum of G is attained ---
  max  = - 1.e+10_O
  kmin =   0
  do k = 1, N
    if (G(k) > max) then
      max  = G(k)
      kmin = k
    end if
  end do
end subroutine PYVct
!***********************************************************************************
function f(c,u) result(func)
  use parameters
  real(O),intent(in) :: c, u
  real(O) :: func
  real(O) :: a, b, d, g
!
  a =   (1._O + 2._O * c)**2 / (1._O - c)**4
  b = - 6._O * c * (1._O + 0.5_O * c)**2 / (1._O - c)**4
  d =   0.5_O * c * a
  g =   (a + b + d) * u**4 * cos(u) - (a + 2 * b + 4 * d) * u**3 * sin(u) -         &
        2._O * (b + 6 * d) * u**2 * cos(u) + 2._O * b * u**2 +                      &
        24._O * d * u * sin(u) + 24._O * d * (cos(u) - 1._O)
  g =   (u**6 / (u**6 - 24._O * c * g) - 1._O) / 24._O / c
  func = 2._O * g * u / Pi
end function f
! **********************************************************************************
subroutine product_AverageTmatrix (Nrank, tv11, tv12, tv21, tv22, ntp, a, nap, map, &
           b, nbp, mbp)
!-----------------------------------------------------------------------------------
!     The routine computes the matrix product:                                     !
!         | t11   t12 |   | a11   a12 |   | t11*a11 + t12*a21   t11*a12 + t12*a22 |!
!     b = |           | * |           | = |                                       |!
!         | t21   t22 |   | a21   a22 |   | t21*a11 + t22*a21   t21*a12 + t22*a22 |!
!     where t11, t12, t21, t22 are diagonal matrices.                              !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Nrank, ntp, nap, map, nbp, mbp, j, i
  complex(O) :: tv11(ntp), tv12(ntp), tv21(ntp), tv22(ntp), a(nap,map), b(nbp,mbp)
!
  do i = 1, Nrank
    do j = 1, Nrank
      b(i,j)             = tv11(i) * a(i,j)       + tv12(i) * a(i+Nrank,j)
	  b(i,j+Nrank)       = tv11(i) * a(i,j+Nrank) + tv12(i) * a(i+Nrank,j+Nrank)
      b(i+Nrank,j)       = tv21(i) * a(i,j)       + tv22(i) * a(i+Nrank,j)
	  b(i+Nrank,j+Nrank) = tv21(i) * a(i,j+Nrank) + tv22(i) * a(i+Nrank,j+Nrank)
    end do
  end do
end subroutine product_AverageTmatrix
! ***********************************************************************************
! *             FAST SIN TRANSFORM ROUTINE FROM NUMERICAL RECIPES                   *
! ***********************************************************************************
subroutine SINFT (Y, N)
  use parameters
  implicit none
  integer :: N, M, j
  real(O) :: Y(N), wr, wi, wpr, wpi, wtemp, theta, Y1, Y2, sum
!
  theta = Pi / N
  wr  =   1._O
  wi  =   0._O
  wpr = - 2._O * sin(0.5_O * theta)**2
  wpi =   sin(theta)
  M   =   N / 2
  Y(1) = 0._O
  do j = 1, M
    wtemp = wr
    wr = wr * wpr - wi * wpi + wr
    wi = wi * wpr + wtemp * wpi + wi
    Y1 = wi * (Y(j+1) + Y(N-j+1))
    Y2 = 0.5_O * (Y(j+1) - Y(N-j+1))
    Y(j+1)   = Y1 + Y2
    Y(N-j+1) = Y1 - Y2
  end do
  call REALFT (Y, M, 1)
  sum  = 0._O
  Y(1) = 0.5_O * Y(1)
  Y(2) = 0._O
  do j = 1, N - 1, 2
    sum    = sum + Y(j)
    Y(j)   = Y(j+1)
    Y(j+1) = sum
  end do
end subroutine SINFT
!*********************************************************************************
subroutine REALFT (Y, N, isign)
  use parameters
  implicit none
  integer :: N, isign, n2p3, i, i1, i2, i3, i4
  real(O) :: Y(2*N), wr, wi, wpr, wpi, wtemp, c1, c2, h1r, h1i, h2r, h2i, theta
!
  theta = Pi / N
  c1    = 0.5_O
  if (isign == 1) then
    c2 = - 0.5_O
    call FOUR (Y, N, +1)
  else
    c2    =   0.5_O
    theta = - theta
  end if
  wpr  = - 2._O * sin(0.5_O * theta)**2
  wpi  =   sin(theta)
  wr   =   1._O + wpr
  wi   =   wpi
  n2p3 =   2 * N + 3
  do i = 2, N/2 + 1
    i1  = 2 * i - 1
    i2  = i1 + 1
    i3  = n2p3 - i2
    i4  = i3 + 1
    h1r =   c1 * (Y(i1) + Y(i3))
    h1i =   c1 * (Y(i2) - Y(i4))
    h2r = - c2 * (Y(i2) + Y(i4))
    h2i =   c2 * (Y(i1) - Y(i3))
    Y(i1) =   h1r + wr * h2r - wi * h2i
    Y(i2) =   h1i + wr * h2i + wi * h2r
    Y(i3) =   h1r - wr * h2r + wi * h2i
    Y(i4) = - h1i + wr * h2i + wi * h2r
    wtemp = wr
    wr = wr * wpr - wi * wpi + wr
    wi = wi * wpr + wtemp * wpi + wi
  end do
  if (isign == 1) then
    h1r  = Y(1)
    Y(1) = h1r + Y(2)
    Y(2) = h1r - Y(2)
  else
    h1r  = Y(1)
    Y(1) = c1 * (h1r + Y(2))
    Y(2) = c1 * (h1r - Y(2))
    call FOUR (Y, N, -1)
  end if
end subroutine REALFT
!*********************************************************************************
subroutine FOUR (Y, NN, isign)
  use parameters
  implicit none
  integer :: NN, isign, n, j, i, m, mmax, istep
  real(O) :: Y(2*NN), tempr, tempi, wr, wi, wpr, wpi, wtemp, theta
!
  n = 2 * nn
  j = 1
  do i = 1, n, 2
    if (j > i) then
      tempr  = Y(j)
      tempi  = Y(j+1)
      Y(j)   = Y(i)
      Y(j+1) = Y(i+1)
      Y(i)   = tempr
      Y(i+1) = tempi
    end if
    m = n / 2
    do while (m >= 2 .and. j > m)
      j = j - m
      m = m / 2
    end do
    j = j + m
  end do
  mmax = 2
  do while (n > mmax)
    istep =   2 * mmax
    theta =   2._O * Pi / (isign * mmax)
    wpr   = - 2._O * sin(0.5_O * theta)**2
    wpi   =   sin(theta)
    wr = 1._O
    wi = 0._O
    do m = 1, mmax, 2
      do i = m, n, istep
        j = i + mmax
        tempr  = wr * Y(j) - wi * Y(j+1)
        tempi  = wr * Y(j+1) + wi * Y(j)
        Y(j)   = Y(i) - tempr
        Y(j+1) = Y(i+1) - tempi
        Y(i)   = Y(i) + tempr
        Y(i+1) = Y(i+1) + tempi
      end do
      wtemp = wr
      wr = wr * wpr - wi * wpi + wr
      wi = wi * wpr + wtemp * wpi + wi
    end do
    mmax = istep
  end do
end subroutine FOUR


      SUBROUTINE RES (
     *     T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR, senpara)
C-----------------------------------------------------------------------
C This routine computes the residual vector, using Subroutine FWEB
C for the right-hand sides.
C-----------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*),UPRIME(*),DELTA(*),RPAR(*),IPAR(*),senpara(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      CALL FWEB (T, U, DELTA, RPAR,senpara)
C
      DO 30 JY = 1,MY
         IYOFF = MXNS*(JY-1)
         DO 20 JX = 1,MX
            IC0 = IYOFF + NS*(JX-1)
            DO 10 I = 1,NS
               ICI = IC0 + I
               IF (I .GT. NP) THEN
                  DELTA(ICI) = -DELTA(ICI)
               ELSE
                  DELTA(ICI) = UPRIME(ICI) - DELTA(ICI)
               ENDIF
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
C
      RETURN
C------------  End of Subroutine RESWEB  -------------------------------
      END
      SUBROUTINE FWEB (T, CC, CRATE, RPAR, senpara)
C-----------------------------------------------------------------------
C This routine computes the right-hand sides of all the equations
C and returns them in the array CRATE.
C The interaction rates are computed by calls to WEBR, and these are
C saved in RPAR(1),...,RPAR(NEQ) for use later in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CRATE(*), RPAR(*), senpara(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        IDYU = MXNS
        IF (JY .EQ. MY) IDYU = -MXNS
        IDYL = MXNS
        IF (JY .EQ. 1) IDYL = -MXNS
        DO 40 JX = 1,MX
          IC = IYOFF + NS*(JX-1) + 1
C Get interaction rates at one point (X,Y).
          CALL WEBR (T, JX, JY, CC(IC), RPAR(2+IC), senpara)
          IDXU = NS
          IF (JX .EQ. MX) IDXU = -NS
          IDXL = NS
          IF (JX .EQ. 1) IDXL = -NS
          DO 20 I = 1,NS
            ICI = IC + I - 1
C Do differencing in Y.
            DCYLI = CC(ICI) - CC(ICI-IDYL)
            DCYUI = CC(ICI+IDYU) - CC(ICI)
C Do differencing in X.
            DCXLI = CC(ICI) - CC(ICI-IDXL)
            DCXUI = CC(ICI+IDXU) - CC(ICI)
C Collect terms and load CRATE elements.
            CRATE(ICI) = COY(I)*(DCYUI - DCYLI) + COX(I)*(DCXUI - DCXLI)
     1                  + RPAR(2+ICI)
 20         CONTINUE
 40       CONTINUE
 60    CONTINUE
      RETURN
C------------  End of Subroutine FWEB  ---------------------------------
      END

      SUBROUTINE WEBR (T, JX, JY, C, CRATE, senpara)
C-----------------------------------------------------------------------
C This routine computes one block of the interaction term R of the
C system, namely block (JX,JY), for use in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION senpara(*)
      DIMENSION C(*), CRATE(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      ALPH = senpara(1)
      BETA = senpara(2)
c      ALPH = 50.0D0
c      BETA = 100.0D0
      Y = REAL(JY-1)*DY
      X = REAL(JX-1)*DX
      DO 10 I = 1,NS
 10     CRATE(I) = 0.0D0
      DO 15 J = 1,NS
        CALL DAXPY (NS, C(J), ACOEF(1,J), 1, CRATE, 1)
 15     CONTINUE
      FAC = 1.0D0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
      DO 20 I = 1,NS
         CRATE(I) = C(I)*(BCOEF(I)*FAC + CRATE(I))
c         CRATE(I) = 100.d0*(BCOEF(I)*FAC + CRATE(I))
 20      continue
      RETURN
C------------  End of Subroutine WEBR  ---------------------------------
      END
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end


      function fortran() bind(C)
      use, intrinsic :: iso_c_binding, only: dp=>c_double
      implicit none

      real(dp) :: r, fortran

      call random_number(r)

      fortran = 2._dp**r

      end function fortran


program logical_order
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    integer, parameter :: n = 10
    logical, parameter :: normalize = .true.
    real(kind=dp), dimension(n) :: x
    real(kind=dp) :: result
    integer :: i

    do i = 1, n
        x(i) = real(i*i, kind=dp)
    end do
    result = accumulate(x)
    print '(A, F10.1)', 'result, not normalized = ', result
    result = accumulate(x, normalize)
    print '(A, F10.1)', 'result, normalized = ', result

contains

    function accumulate(x, normalize) result(acc)
        implicit none
        real(kind=dp), dimension(:), intent(in) :: x
        logical, intent(in), optional :: normalize
        real(kind=dp) :: acc
        acc = sum(x)
        if (present(normalize) .and. normalize) then
            acc = acc/size(x)
        end if
    end function accumulate

end program logical_order


*DECK RSB
      SUBROUTINE RSB (NM, N, MB, A, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSB
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric band matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A6
C***TYPE      SINGLE PRECISION (RSB-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC BAND matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the half band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB must be less than or
C          equal to N.  MB is an INTEGER variable.
C
C        A contains the lower triangle of the real symmetric band
C          matrix.  Its lowest subdiagonal is stored in the last
C          N+1-MB  positions of the first column, its next subdiagonal
C          in the last  N+2-MB  positions of the second column, further
C          subdiagonals similarly, and finally its principal diagonal
C          in the  N  positions of the last column.  Contents of storage
C          locations not part of the matrix are arbitrary.  A is a
C          two-dimensional REAL array, dimensioned A(NM,MB).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        W contains the eigenvalues in ascending order.  W is a one-
C          dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The
C          eigenvectors are orthonormal.  Z is a two-dimensional
C          REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          12*N       if MB is either non-positive or greater than N,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors, if requested,
C                     should be correct for indices 1, 2, ..., IERR-1.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  BANDR, TQL2, TQLRAT
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSB
C
      INTEGER N,MB,NM,IERR,MATZ
      REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
      LOGICAL TF
C
C***FIRST EXECUTABLE STATEMENT  RSB
      IF (N .LE. NM) GO TO 5
      IERR = 10 * N
      GO TO 50
    5 IF (MB .GT. 0) GO TO 10
      IERR = 12 * N
      GO TO 50
   10 IF (MB .LE. N) GO TO 15
      IERR = 12 * N
      GO TO 50
C
   15 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      TF = .FALSE.
      CALL  BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 TF = .TRUE.
      CALL  BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END


module ldltf_double

  interface num_neg_D
    module procedure num_neg_D_double
  end interface

contains

  integer function num_neg_D_double( n, LDLT, ld, ipiv )
! Counts negative eigenvalues of factor D

    implicit none

    double precision, parameter :: ZERO = 0.0D0
    integer, intent(in) :: n, ld
    double precision, intent(in) :: LDLT(ld, n)
    integer, intent(in) :: ipiv(n)
    integer :: nneg
    integer :: i
    double precision :: r, s, t

    i = 1
    nneg = 0
    do while ( i <= n )
      s = LDLT(i, i)
      if ( ipiv(i) < 0 ) then
        t = LDLT(i + 1, i)
        r = LDLT(i + 1, i + 1)
        if ( s*r - t*t < ZERO ) then
          nneg = nneg + 1
        else if ( s*r - t*t > ZERO .and. s + r < ZERO ) then
          nneg = nneg + 2
        end if
        i = i + 2
      else
        if ( s < ZERO ) nneg = nneg + 1
        i = i + 1
      end if
    end do
    num_neg_D_double = nneg

  end function num_neg_D_double

end module ldltf_double

module ldltf
  use ldltf_double
end module ldltf


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lamf in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp lamf
!   with respect to varying inputs: *temp
!   Plus diff mem management of: temp:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief calculate the thermal conductivity kf in W/(m*K) of water
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return thermal conductivity [W/(m*K)]
!> @details
!> Calculate the thermal conductivity kf in W/(m*K) of freshwater,
!> given temperature in degC. Thermal conductivity of freshwater, kfw
!> is calculated using the Phillips (1981) formulation (page 8). \n\n
!>
!> Source:\n\n
!>
!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
!> Technical databook for geothermal energy utilization (1981).
!> http://dx.doi.org/10.2172/6301274 \n\n
!>
!> Range of validity:  20 to 330 degC\n\n
!>
!>      temperature tlocal in [C]\n
SUBROUTINE LAMF_AD0(i, j, k, ismpl, lamf_ad)
  use arrays

  USE ARRAYS_AD

  IMPLICIT NONE
! Location indices
  INTEGER, INTENT(IN) :: i
  INTEGER, INTENT(IN) :: j
  INTEGER, INTENT(IN) :: k
! Sample index
  INTEGER :: ismpl
! Temperature (degC)
  DOUBLE PRECISION :: tlocal
  DOUBLE PRECISION :: tlocal_ad
! Monomials of temperatures quotient
  DOUBLE PRECISION :: tr, tr2, tr3, tr4
  DOUBLE PRECISION :: tr_ad, tr2_ad, tr3_ad, tr4_ad
! Coefficients of approximation
  DOUBLE PRECISION, PARAMETER :: c0=-0.92247d0
  DOUBLE PRECISION, PARAMETER :: c1=2.8395d0
  DOUBLE PRECISION, PARAMETER :: c2=1.8007d0
  DOUBLE PRECISION, PARAMETER :: c3=0.52577d0
  DOUBLE PRECISION, PARAMETER :: c4=0.07344d0
  DOUBLE PRECISION :: lamf
  DOUBLE PRECISION :: lamf_ad
! Local Temperature in degC
  tlocal = temp(i, j, k, ismpl)
! Monomials of temperature quotient
  tr = (tlocal+273.15d0)/273.15d0
  tr2 = tr*tr
  tr3 = tr2*tr
! Thermal conductivity [W/(m*K)]
  tr4_ad = -(c4*lamf_ad)
  tr3_ad = c3*lamf_ad + tr*tr4_ad
  tr2_ad = tr*tr3_ad - c2*lamf_ad
  tr_ad = c1*lamf_ad + tr3*tr4_ad + tr2*tr3_ad + 2*tr*tr2_ad
  tlocal_ad = tr_ad/273.15d0
  temp_ad(i, j, k, ismpl) = temp_ad(i, j, k, ismpl) + tlocal_ad
END SUBROUTINE LAMF_AD0


      function contur(array,idim,ii,jj)
c
c --- find nice contour interval resulting in approx. 'maxnum' contour lines
c --- common/conrng/ contains minium and miximum on return.
c
      real array(idim,1)
      data flag/-.03125/
      data maxnum/22/
c
      common/conrng/ amn,amx
c
      amx=-1.e25
      amn= 1.e25
      imn=-1
      jmn=-1
      imx=-1
      jmx=-1
      do 1 i=1,ii
      do 1 j=1,jj
      if (array(i,j).ne.flag) then
        if (array(i,j).gt.amx) then
          imx=i
          jmx=j
          amx=array(i,j)
        end if
        if (array(i,j).lt.amn) then
          imn=i
          jmn=j
          amn=array(i,j)
        end if
      end if
 1    continue
c
      if (amx.gt.amn) go to 2
      contur=0.
      write (*,100) amx
 100  format (//' field to be contoured is constant ...',1pe13.5)
      return
c
 2    contur=10.**int(alog10((amx-amn)/float(maxnum))-2.)
 4    if (int((amx-amn)/contur).lt.maxnum) go to 3
      contur=contur*2.
      if (int((amx-amn)/contur).lt.maxnum) go to 3
      contur=contur*2.5
      if (int((amx-amn)/contur).lt.maxnum) go to 3
      contur=contur*2.
      go to 4
 3    write (*,'(a,1p,e9.2,a,2i5,a,e9.2,a,2i5,a,e9.2,i5)')
     .     'min ',amn,' at',imn,jmn,
     .   '  max ',amx,' at',imx,jmx,
     .   '  intvl.,lines ',contur,int((amx-amn)/contur)
      return
      end
      function contur_colors(array,idim,ii,jj,maxnum)
c
c --- find nice contour interval resulting in approx. 'maxnum' contour lines
c --- common/conrng/ contains minium and miximum on return.
c
      real array(idim,1)
      data flag/-.03125/
c
      common/conrng/ amn,amx
c
      amx=-1.e25
      amn= 1.e25
      imn=-1
      jmn=-1
      imx=-1
      jmx=-1
      do 1 i=1,ii
      do 1 j=1,jj
      if (array(i,j).ne.flag) then
        if (array(i,j).gt.amx) then
          imx=i
          jmx=j
          amx=array(i,j)
        end if
        if (array(i,j).lt.amn) then
          imn=i
          jmn=j
          amn=array(i,j)
        end if
      end if
 1    continue
c
      if (amx.gt.amn) go to 2
      contur_colors=0.
      write (*,100) amx
 100  format (//' field to be contoured is constant ...',1pe13.5)
      return
c
 2    contur_colors=10.**int(alog10((amx-amn)/float(maxnum))-2.)
      write(*,*) 'cc = ',contur_colors
 4    if (int((amx-amn)/contur_colors).lt.3*maxnum/2) go to 3
      contur_colors=contur_colors*2.
      write(*,*) 'cc = ',contur_colors
      if (int((amx-amn)/contur_colors).lt.3*maxnum/2) go to 3
      contur_colors=contur_colors*2.5
      write(*,*) 'cc = ',contur_colors
      if (int((amx-amn)/contur_colors).lt.3*maxnum/2) go to 3
      contur_colors=contur_colors*2.
      write(*,*) 'cc = ',contur_colors
      write(*,*) 'cc - goto 4'
      go to 4
 3    write (*,'(a,1p,e9.2,a,2i5,a,e9.2,a,2i5,a,e9.2,i5)')
     .     'min ',amn,' at',imn,jmn,
     .   '  max ',amx,' at',imx,jmx,
     .   '  intvl.,lines ',contur_colors,int((amx-amn)/contur_colors)
      return
      end


!> \file randmod.f90
!! Innocent defined module for normal random numbers
!<

!> Module for random numbers generation
!! used for Data Assimilation purpose
!! It is mandatory to call init_normal_rand to initialize the module before using it
!! One may call finilize_normal_rand to finilize the module
!! The method used here consists in a quasi inversion of the CDF. The space is subdivided into small intervals. Given a uniform random value between 0 and 1, the CDF of the normal distribution is inverted at the value. When the inversion falls into an interval, the middle of the interval is considered as the associated normal random value.
!<
MODULE randmod
  USE general_constant
  USE general_tools, only: search_pos_inc, init_random_seed
  USE debug_tools
IMPLICIT NONE
  !> default number of possible values at the right of the mean
  INTEGER, PARAMETER :: DEFAULT_NRIGHT = 4096!1024

  !> user defined type to keep and manage information on a random numbers generator
  TYPE rng_environment
    LOGICAL :: l_init = .FALSE. !< Says if the radom number generator environment is initialized or not
    LOGICAL :: l_stat = .FALSE. !< Save statistics (frequency) for analysis? Statistics can be used to check the Gaussianity of a gaussian generator
    !for statistics
    INTEGER :: i_nCall  = 0     !< number of call to the generator, used for statistics
    INTEGER :: i_lb, i_ub       !< bounds of the statistics array
    REAL(KIND=cp), DIMENSION(:), ALLOCATABLE :: ra_rands!<Vector of possible values
    REAL(KIND=cp), DIMENSION(:), ALLOCATABLE :: ra_cdf  !< CDF at possibles values

    REAL(KIND=cp), DIMENSION(:), ALLOCATABLE :: ra_pdf  !< PDF of the generator
    INTEGER, DIMENSION(:), ALLOCATABLE :: ia_stats !< frequency of random numbers generated in a set of predefined intervals
  END TYPE rng_environment

  !> user type to store parameter of random Gaussian number generator
  TYPE, PRIVATE :: gaussian_param
    INTEGER :: i_nright = 0     !< Number of Number of possible values (greater than the mean) that can be generated
    REAL(KIND=cp) :: r_radius   !< Distance from the mean to the maximum/minimum number that can be generated
    REAL(KIND=cp) :: r_mean     !< mean of the distribution
    REAL(KIND=cp) :: r_sigma    !< Standard deviation of the distribution
    REAL(KIND=cp) :: r_step     !< step between possible successive values
    TYPE(rng_environment) :: t_env  !< environment of the random number generator
  END TYPE gaussian_param

  INTERFACE normal_random
    MODULE PROCEDURE normal_random_scalar
    MODULE PROCEDURE normal_random_vector
  END INTERFACE normal_random

  TYPE(gaussian_param), PRIVATE, SAVE :: tm_gaussp !< parameter for the Gaussian generator

CONTAINS

!--- info
  !> \brief Initializes the environment for a random number generator
  !! \param[in,out] td_rnge environment to be initialized
  !! \param[in] id_lb lower bound index of the environments arrays
  !! \param[in] id_ub upper bound index of the environments arrays
  !! \param[in] stat status of the statistics
  !<
  SUBROUTINE init_rng_environment(td_rnge, id_lb, id_ub, stat)
    TYPE(rng_environment), INTENT(INOUT) :: td_rnge
    INTEGER, INTENT(IN) :: id_lb, id_ub
    LOGICAL, INTENT(IN), OPTIONAL :: stat

    IF ( PRESENT( stat) ) THEN
      td_rnge%l_stat = stat
    ELSE
      td_rnge%l_stat = .FALSE.
    END IF
    td_rnge%i_lb = id_lb
    td_rnge%i_ub = id_ub
    IF( ALLOCATED(td_rnge%ra_rands) )DEALLOCATE(td_rnge%ra_rands)
    IF( ALLOCATED(td_rnge%ra_cdf  ) )DEALLOCATE(td_rnge%ra_cdf  )
    ALLOCATE( td_rnge%ra_rands(td_rnge%i_lb:td_rnge%i_ub),&
              td_rnge%ra_cdf  (td_rnge%i_lb:td_rnge%i_ub) &
    )
    td_rnge%ra_rands = 0.0_cp
    td_rnge%ra_cdf   = 0.0_cp
    !stats
    IF(td_rnge%l_stat)THEN
      IF( ALLOCATED(td_rnge%ra_pdf) )DEALLOCATE(td_rnge%ra_pdf)
      IF( ALLOCATED(td_rnge%ia_stats) )DEALLOCATE(td_rnge%ia_stats)
      ALLOCATE(td_rnge%ra_pdf(td_rnge%i_lb:td_rnge%i_ub),&
              td_rnge%ia_stats(td_rnge%i_lb:td_rnge%i_ub) &
      )
      td_rnge%i_nCall  = 0
      td_rnge%ia_stats = 0
      td_rnge%ra_pdf   = 0.0_cp
    END IF
    td_rnge%l_init = .TRUE.
  END SUBROUTINE init_rng_environment

  !> \brief finalizes the environment for a random number generator
  !! \param[in,out] td_rnge environment to be initialized
  !<
  SUBROUTINE finilize_rng_environment(td_rnge)
    TYPE(rng_environment), INTENT(INOUT) :: td_rnge

    !statistics
    IF(td_rnge%l_init)THEN
      IF(td_rnge%l_stat)THEN
        DEALLOCATE(td_rnge%ra_pdf, td_rnge%ia_stats )
      END IF
      DEALLOCATE( td_rnge%ra_rands, td_rnge%ra_cdf )
      td_rnge%i_lb =  0
      td_rnge%i_ub = -1! an upper bound less than the lower bound
      td_rnge%i_nCall  = -1
      td_rnge%l_init = .FALSE.
    END IF
  END SUBROUTINE finilize_rng_environment

  !> \brief generates a random number from the distribution associated with the random number generator environment
  !! \param[in,out] td_rnge environment of the random number generator to be used
  !<
  FUNCTION generate_rand(td_rnge) RESULT(rl_rand)
    TYPE(rng_environment), INTENT(INOUT) :: td_rnge
    REAL(KIND=cp) :: rl_cdf, rl_rand
    INTEGER :: il_pos, il_ntry

    IF(.NOT.td_rnge%l_init)THEN
      CALL debug("In generate_rand: random number generator is not initialized", tag=dALLWAYS)
      CALL ABORT()
    END IF

    CALL RANDOM_NUMBER(rl_cdf)
    il_pos = search_pos_inc(rl_cdf, td_rnge%ra_cdf, il_ntry) + td_rnge%i_lb - 1
    !WRITE(*,FMT="(A,ES13.5E2,A,I5,A,I5,A)")"Find ", rl_cdf, " At ", il_pos, " with ", il_ntry, " tries"
    rl_rand = td_rnge%ra_rands(il_pos)
    IF(td_rnge%l_stat)THEN
      td_rnge%i_nCall = td_rnge%i_nCall + 1
      td_rnge%ia_stats(il_pos) = td_rnge%ia_stats(il_pos) + 1!for stats
    END IF
  END FUNCTION generate_rand

!   !> \brief updates the statistics on a random number generator using the cfd
!   !! \param[in,out] td_rnge structure that keeps stats
!   !! \param[in] index of the position to be updated
!   !! this function is used to update statistics for external random number generator
!   !<
!   SUBROUTINE update_rnge_stat(td_rnge, pos)
!     TYPE(rng_environment), INTENT(INOUT) :: td_rnge
!     INTEGER, INTENT(IN) :: pos
!     !local variables
!     INTEGER :: il_ntry
!
!     il_pos = search_pos_inc(rd_rand, td_rnge%ra_rands, il_ntry) + td_rnge%i_lb - 1
!     IF(td_rnge%l_stat)THEN
!       td_rnge%i_nCall = td_rnge%i_nCall + 1
!       td_rnge%ia_stats(il_pos) = td_rnge%ia_stats(il_pos) + 1!for stats
!     END IF
!   END SUBROUTINE update_rnge_stat

  !> returns the statistics of the random number generator
  !< \param[in] td_rnge, environment of the random number generator to be used
  !! \param[out] ssize, size of the statistic vector
  !! \param[out] x vector of abcissa of the statistic points
  !! \param[out] y vector of estimated pdf based on calls to ramdom_normal since the last call to init_normal_rand
  !! \param[out] pdf vector of true pdf
  !! \param[out] stat call stat, return 0 if OK, -1 if statistics are not saved (call to init_normal_rand with stat = .FALSE., default)
  !! \detail this routine return usefull information to check the gaussianity of the seauence of number generated since the last call to init_normal_rand
  !! \this routine should be called only if init_normal_rand has been called with stat = .TRUE.
  !<
  SUBROUTINE get_rng_stat(td_rnge, ssize, x, y, pdf, stat)
    TYPE(rng_environment), INTENT(IN) :: td_rnge
    INTEGER, INTENT(OUT), OPTIONAL :: ssize, stat
    REAL(KIND=cp), DIMENSION(:), INTENT(OUT), OPTIONAL :: x, y, pdf
    !local var
    INTEGER :: il_tmp

    IF( PRESENT(ssize) ) ssize = SIZE(td_rnge%ia_stats)
    IF(td_rnge%l_stat)THEN
      IF( PRESENT(x) ) x = td_rnge%ra_rands
      IF( PRESENT(y) )THEN
        !the count of values in a small interval is assumed to be the aproximation (rectangle methods) of the probability of a random values to be in this interval,
        il_tmp = td_rnge%i_lb
        y = ( REAL(td_rnge%ia_stats, cp)/REAL(td_rnge%i_nCall,cp) )/( td_rnge%ra_rands(il_tmp+1)-td_rnge%ra_rands(il_tmp) )
      END IF
      IF( PRESENT(pdf) ) pdf = td_rnge%ra_pdf
      IF( PRESENT(stat) ) stat = 0
    ELSE
      IF( PRESENT(stat) ) stat = -1
    END IF
  END SUBROUTINE get_rng_stat

!------------------
  !> \brief Generates a gaussian random number of preset standard deviation and mean
  !! initially named normal_rand_scalar_func and defined in the interface normal_rand
  !! Since the other porcedure of the interface normal_rand are subroutines, it did not respect the standard, although working with intel compilers
  !<
  FUNCTION normal_rand() RESULT(rl_rand)
    !local var
    REAL(KIND=cp) :: rl_rand
    !REAL(KIND=cp) :: rl_sign, rl_cdf
    !INTEGER :: il_ntry, il_pos

    rl_rand = generate_rand(tm_gaussp%t_env)
    !il_pos = search_pos_inc(rl_cdf, tm_gaussp%t_env%ra_cdf, il_ntry) + tm_gaussp%t_env%i_lb - 1
    !rl_rand = tm_gaussp%t_env%ra_rands(il_pos)
  END FUNCTION normal_rand

  !> \brief Generates a gaussian random number of preset standard deviation and mean
  !!
  !<
  SUBROUTINE normal_random_scalar(rd_rand)
    REAL(KIND=cp), INTENT(OUT) :: rd_rand
    !REAL(KIND=cp) :: rl_sign, rl_cdf
    !INTEGER :: il_ntry, il_pos

    rd_rand = generate_rand(tm_gaussp%t_env)
    !il_pos = search_pos_inc(rl_cdf, tm_gaussp%t_env%ra_cdf, il_ntry) + tm_gaussp%t_env%i_lb - 1
    !rd_rand = tm_gaussp%t_env%ra_rands(il_pos)
  END SUBROUTINE normal_random_scalar

  !> \brief Generates a vector of independant gaussian random numbers of preset standard deviation and mean
  !!
  !<
  SUBROUTINE normal_random_vector(rda_rand)
    REAL(KIND=cp), DIMENSION(:), INTENT(OUT) :: rda_rand
    !REAL(KIND=cp) :: rl_sign, rl_cdf
    INTEGER :: ibi!, il_ntry, il_pos

    DO ibi = 1, SIZE(rda_rand)
      CALL init_random_seed()
      rda_rand(ibi) = generate_rand(tm_gaussp%t_env)
      !il_pos = search_pos_inc(rl_cdf, tm_gaussp%t_env%ra_cdf, il_ntry) + tm_gaussp%t_env%i_lb - 1
      !rd_rand = tm_gaussp%t_env%ra_rands(il_pos)
    END DO
  END SUBROUTINE normal_random_vector

  !> \brief Initializes the Gaussian generator
  !! \param[in] mu mean of the distribution
  !! \param[in] sigma Standard deviation of the distribution
  !! \param[in] radius Distance from the mean to the maximum/minimum number that can be generated, default is set to 4*rd_sigma
  !! \param[in] nright Number of possible values greater than the mean, default is set to 127
  !! \param[in] stat says if it is necessary to save statistics
  !! \details the total number of possible values that can be generated is 2*id_nright + 1
  !<
  SUBROUTINE init_normal_rand(mu, sigma, radius, nright, stat)
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: mu, sigma
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: radius
    INTEGER, OPTIONAL, INTENT(IN) :: nright
    LOGICAL, OPTIONAL, INTENT(IN) :: stat
    REAL(KIND=cp) :: rl_hstep
    INTEGER :: ibi, il_lb, il_ub

    IF ( PRESENT(mu) ) THEN
      tm_gaussp%r_mean  = mu
    ELSE
      tm_gaussp%r_mean = 0.0_cp
    END IF
    IF ( PRESENT(sigma) ) THEN
      tm_gaussp%r_sigma = sigma
    ELSE
      tm_gaussp%r_sigma = 1.0_cp
    END IF
    IF( PRESENT(radius) ) THEN
      tm_gaussp%r_radius = radius
    ELSE
      tm_gaussp%r_radius = 4.0_cp*tm_gaussp%r_sigma
    END IF
    IF( PRESENT(nright) ) THEN
      tm_gaussp%i_nright = nright
    ELSE
      tm_gaussp%i_nright = DEFAULT_NRIGHT
    END IF
    il_lb = -tm_gaussp%i_nright
    il_ub =  tm_gaussp%i_nright-1

    CALL init_rng_environment(tm_gaussp%t_env, il_lb, il_ub, stat)

    tm_gaussp%r_step = tm_gaussp%r_radius/( REAL(tm_gaussp%i_nright, cp)-0.5_cp)
    rl_hstep= tm_gaussp%r_step/2.0_cp
    DO ibi = il_lb, il_ub
      tm_gaussp%t_env%ra_rands(ibi) = (ibi)*tm_gaussp%r_step + tm_gaussp%r_mean
      tm_gaussp%t_env%ra_cdf(ibi)   = normal_cdf( tm_gaussp%t_env%ra_rands(ibi)-rl_hstep, tm_gaussp%r_mean, tm_gaussp%r_sigma)
      !stats
      IF(tm_gaussp%t_env%l_stat)THEN
        tm_gaussp%t_env%ia_stats(ibi) = 0
        tm_gaussp%t_env%ra_pdf(ibi) = &
          normal_pdf( tm_gaussp%t_env%ra_rands(ibi), tm_gaussp%r_mean, tm_gaussp%r_sigma )
      END IF
      !CALL debug(ibi, 'init_normal_rand loop..', tag=dALLWAYS)
    END DO
    CALL init_random_seed()
  END SUBROUTINE init_normal_rand

  SUBROUTINE copy_normal_rnge(td_rnge)
    TYPE(rng_environment), INTENT(INOUT) :: td_rnge

    CALL finilize_rng_environment(td_rnge)
    td_rnge%l_init = tm_gaussp%t_env%l_init
    IF(tm_gaussp%t_env%l_init)THEN
      CALL init_rng_environment(td_rnge, tm_gaussp%t_env%i_lb, tm_gaussp%t_env%i_ub, tm_gaussp%t_env%l_stat)
      td_rnge%ra_rands = tm_gaussp%t_env%ra_rands
      td_rnge%ra_cdf   = tm_gaussp%t_env%ra_cdf
      IF (td_rnge%l_stat) THEN
        td_rnge%ra_pdf   = tm_gaussp%t_env%ra_pdf
        td_rnge%ia_stats = tm_gaussp%t_env%ia_stats
        td_rnge%i_nCall  = tm_gaussp%t_env%i_nCall
      END IF
    END IF
  END SUBROUTINE copy_normal_rnge

  !> returns statistics of the random module
  !! \param[out] ssize size of the statistic vector
  !! \param[out] x vector of abcissa of the statistic points
  !! \param[out] y vector of estimated pdf based on calls to ramdom_normal since the last call to init_normal_rand
  !! \param[out] pdf vector of true pdf
  !! \param[out] stat call stat, return 0 if OK, -1 if statistics are not saved (call to init_normal_rand with stat = .FALSE., default)
  !! \details this routine return usefull information to check the gaussianity of the seauence of number generated since the last call to \a init_normal_rand.
  !! This routine should be called only if \a init_normal_rand has been called with stat = .TRUE.
  !<
  SUBROUTINE get_normal_stat(ssize, x, y, pdf, stat)
    INTEGER, INTENT(OUT), OPTIONAL :: ssize, stat
    REAL(KIND=cp), DIMENSION(:), INTENT(OUT), OPTIONAL :: x, y, pdf
    !INTEGER :: ibi

    CALL get_rng_stat(tm_gaussp%t_env, ssize, x, y, pdf, stat)
  END SUBROUTINE get_normal_stat

  SUBROUTINE finilize_normal_rand()
    !TYPE(dyn_rVector), DIMENSION(3) :: tla_save
    IF(tm_gaussp%i_nright>0)THEN
      tm_gaussp%i_nright = 0
      CALL finilize_rng_environment(tm_gaussp%t_env)
    END IF
  END SUBROUTINE finilize_normal_rand

  !> \brief Computes the normal probability density function at point x
  !! \param[in] rd_x point where the PDF is calculated
  !! \param[in] mu (optional, default 0) mean of the distribution
  !! \param[in] sigma (optional, default 1) standard deviation of the distribution
  !<
  FUNCTION normal_pdf(rd_x, mu, sigma) RESULT(rl_pdf)
    REAL(KIND=cp), INTENT(IN) :: rd_x
    REAL(KIND=cp), INTENT(IN), OPTIONAL :: mu, sigma
    REAL(KIND=cp) :: rl_pdf, rl_mu, rl_sigma

    IF ( PRESENT(mu) ) THEN
      rl_mu = mu
    ELSE
      rl_mu = 0.0
    END IF
    IF ( PRESENT(sigma) ) THEN
      rl_sigma = sigma
    ELSE
      rl_sigma = 1.0
    END IF

    rl_pdf = ( 1/( rl_sigma*SQRT(2*rp_pi) ) )*exp(-(rd_x-rl_mu)**2/(2.0*rl_sigma**2) )
  END FUNCTION normal_pdf

  !> \brief Computes the normal Cumulative distribution function at point x
  !! \param[in] rd_x point where the CDF is calculated
  !! \param[in] mu (optional, default 0) mean of the distribution
  !! \param[in] sigma (optional, default 1) standard deviation of the distribution
  !<
  FUNCTION normal_cdf(rd_x, mu, sigma) RESULT(rl_cdf)
    REAL(KIND=cp), INTENT(IN) :: rd_x
    REAL(KIND=cp), INTENT(IN), OPTIONAL :: mu, sigma
    REAL(KIND=cp) :: rl_cdf, rl_mu, rl_sigma

    IF ( PRESENT(mu) ) THEN
      rl_mu = mu
    ELSE
      rl_mu = 0.0
    END IF
    IF ( PRESENT(sigma) ) THEN
      rl_sigma = sigma
    ELSE
      rl_sigma = 1.0
    END IF

    rl_cdf = 0.5*( 1 + erf( (rd_x-rl_mu)/(rl_sigma*SQRT(2.0)) ) )
  END FUNCTION normal_cdf

END MODULE randmod


C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.02.01/tstcor                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TSTCOR  (VWIND, PRVWPT, PROJTY, PRP, VPD,BPD,FPD,
     1                    TRNF, VWCENT)

C  TSTCOR tests the pevmm3 function by applying the transform
C  returned by it to the eight corners of the view volume and
C  checking that they are reasonably close to the corners of the
C  projection viewport.
C
C  ------- INPUT PARAMETERS
C  vwind (4)  : view window limits
C  prvwpt (6) : projection viewport limits
C  projty     : projection type
C  prp (3)    : projection reference point
C  vpd        : view plane distance (n-coordinate value)
C  bpd        : back plane distance (n-coordinate value)
C  fpd        : front plane distance (n-coordinate value)
C
C  ------- OUTPUT PARAMETERS:
C  trnf (4,4) : transformation returned by pevmm3
C  vwcent (3) : view window center

      REAL     VWIND(4), PRVWPT(6), PRP(3), VPD,BPD,FPD
      REAL     BAS(4,3), DLT(4,3), ACTPR(3)
      REAL     VWCENT(3), ACTVV(8,3), NVAL
      REAL     EXPPR(8,3), TRNF(4,4), UPARM
      INTEGER  PROJTY, IPROJ, ICOR, ICORX,ICORY,ICORZ, ERRIND, IXYZ
      LOGICAL  APPEQ

C viewtype
      INTEGER    PPARL,     PPERS
      PARAMETER (PPARL = 0, PPERS = 1)

      CHARACTER  MSG*300, XYZ*3

      XYZ = 'XYZ'
C get view window center
      VWCENT(1) = (VWIND(1)+VWIND(2))/2
      VWCENT(2) = (VWIND(3)+VWIND(4))/2
      VWCENT(3) = VPD

C determine BASE and DELTA for 4 corner projectors - each line in
C parametric form:
C   x = BASx + uparm*DLTx
C   y = BASy + uparm*DLTy
C   z = BASz + uparm*DLTz

C  Order of projectors is:
C     1: left,  bottom
C     2: left,  top
C     3: right, bottom
C     4: right, top

      IF (PROJTY .EQ. PPARL) THEN
C deltas for all 4 projectors are the same - parallel projectors
         DO 110 IPROJ = 1,4
         DO 120 IXYZ  = 1,3
            DLT (IPROJ, IXYZ) = VWCENT(IXYZ) - PRP(IXYZ)
120      CONTINUE
110      CONTINUE
      ELSEIF (PROJTY .EQ. PPERS) THEN
C delta based on PRP and *corners* of view window
         DO 210 ICORX = 1,2
         DO 215 ICORY = 3,4
C which projector?
            IPROJ = 2*ICORX + ICORY - 4
            DLT (IPROJ, 1) = VWIND(ICORX) - PRP(1)
            DLT (IPROJ, 2) = VWIND(ICORY) - PRP(2)
            DLT (IPROJ, 3) = VPD          - PRP(3)
215      CONTINUE
210      CONTINUE
      ELSE
         WRITE (MSG, '(A,I5)')
     1      'Illegal projection type passed to TSTCOR:', PROJTY
         CALL UNMSG (MSG)
      ENDIF

C use 4 corners of view window as bases - these are valid
C for either parallel or perspective
      DO 310 ICORX = 1,2
      DO 315 ICORY = 3,4
C which projector?
         IPROJ = 2*ICORX + ICORY - 4
         BAS (IPROJ, 1) = VWIND(ICORX)
         BAS (IPROJ, 2) = VWIND(ICORY)
         BAS (IPROJ, 3) = VPD
315   CONTINUE
310   CONTINUE

C calculate all 8 view volume corners
C labeling of corners: (left, bottom, back = 1, left, bottom, front = 2...
C    right, top, front = 8)
      DO 350 ICOR = 1,8
C which projector
         IPROJ = (ICOR+1) / 2
         IF (MOD(ICOR,2) .EQ. 1) THEN
            NVAL = BPD
         ELSE
            NVAL = FPD
         ENDIF

C calculate value of UPARM for parametric lines
         UPARM = (NVAL - BAS (IPROJ,3)) / DLT (IPROJ,3)
C get coordinates for the corner
         DO 360 IXYZ = 1,3
            ACTVV(ICOR,IXYZ) = BAS(IPROJ,IXYZ) + UPARM*DLT(IPROJ,IXYZ)
360      CONTINUE
350   CONTINUE

C expected values for projection:
      DO 410 ICORX = 1,2
      DO 420 ICORY = 3,4
      DO 430 ICORZ = 5,6
C which corner
         ICOR = 4*ICORX + 2*ICORY + ICORZ - 14
         EXPPR(ICOR,1) = PRVWPT(ICORX)
         EXPPR(ICOR,2) = PRVWPT(ICORY)
         EXPPR(ICOR,3) = PRVWPT(ICORZ)
430   CONTINUE
420   CONTINUE
410   CONTINUE

      CALL PEVMM3 (VWIND, PRVWPT, PROJTY, PRP(1),PRP(2),PRP(3),
     1             VPD,BPD,FPD, ERRIND, TRNF)
      IF (ERRIND .NE. 0) THEN
         CALL FAIL
         WRITE (MSG, '(A,I5)')
     1         'Non-zero error code in TSTCOR from PEVMM3:', ERRIND
         CALL INMSG (MSG)
         RETURN
      ENDIF

C transform view volume corners to projection corners
      DO 510 ICOR = 1,8
         CALL ETP3 (ACTVV(ICOR,1), ACTVV(ICOR,2), ACTVV(ICOR,3), TRNF,
     1              ACTPR(     1), ACTPR(     2), ACTPR(     3))
         DO 520 IXYZ = 1,3
            IF ( .NOT. APPEQ( ACTPR(     IXYZ),
     1                        EXPPR(ICOR,IXYZ), 1E-7, 1E-4)) THEN
               CALL FAIL
               WRITE (MSG, '(A,I5,A)') 'Failed on corner #',
     1                ICOR, ', coordinate ' // XYZ(IXYZ:IXYZ)
               CALL INMSG (MSG)
               RETURN
            ENDIF
520      CONTINUE
510   CONTINUE
      CALL PASS

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.02.01/tstprj                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TSTPRJ (PRP, TRNF, VWCENT)

C  TSTPRJ tests that two arbitrary points on a projector are both
C  mapped to the same x-y values in NPC space.

C  ------- INPUT PARAMETERS
C  prp (3)    : projection reference point
C  trnf (4,4) : transformation returned by pevmm3
C  vwcent (3) : view window center

      REAL     PRP(3), VWCENT(3), TRNF(4,4), DLT(3), UPARM
      REAL     VRCPT(3), NPCPT(2,3)
      INTEGER  IXYZ, WHICH
      LOGICAL  APPEQ

C   compute VRC projector passing thru view window center
      DO 110 IXYZ = 1,3
         DLT(IXYZ) = VWCENT(IXYZ) - PRP(IXYZ)
110   CONTINUE

C   pick two points on projector
      DO 210 WHICH = 1,2
C   compute point based on uparm - 3.3 units on each side of PRP
         UPARM = 3.3 * (WHICH*2 - 3)
         DO 220 IXYZ = 1,3
            VRCPT(IXYZ) = PRP(IXYZ) + UPARM * DLT(IXYZ)
220      CONTINUE
C   apply trnf to VRC point to determine transformed NPC point
         CALL ETP3 (VRCPT(      1), VRCPT(      2), VRCPT(      3),
     1        TRNF, NPCPT(WHICH,1), NPCPT(WHICH,2), NPCPT(WHICH,3))
210   CONTINUE

C   pass/fail projector test depending on
C     (cent1x approx= cent2x and cent1y approx= cent2y)
      CALL IFPF (APPEQ( NPCPT(1,1), NPCPT(2,1), 1E-7, 1E-4) .AND.
     1           APPEQ( NPCPT(1,2), NPCPT(2,2), 1E-7, 1E-4))

      END


!> Tests the unit conversion function
PROGRAM test_unit_conversions
    USE unit_conversions
    USE kinds
    IMPLICIT NONE
    REAL(dp) :: time=1.0_dp, temp=300.0_dp, freq=1.0_dp, energy=100.0_dp
    REAL(dp) :: beta=0.0_dp
    REAL(dp) :: eps=1.0E-10

    time = time * convert('fs','au_time')
    beta = 1.0_dp / ( temp * convert('kelvin','au_energy') )
    freq = freq * convert('wvnbr','au_ang_freq')
    energy = energy * convert('wvnbr','au_energy')

    IF ( ABS(time - 41.341373336561368) >= 41.341373336561368/1.0E6_dp ) THEN
        WRITE(*,*) 'failed unit conversion for time, outside tolerance'
        STOP 1
    ELSE IF ( ABS(beta - 1052.5834351695135) >= 1052.5834351695135/1.0E6_dp ) THEN
        WRITE(*,*) 'failed unit conversion for beta/temp, outside tolerance'
        STOP 1
    ELSE IF ( ABS(freq - 4.5563352527599625E-006) >= 4.5563352527599625E-006/1.0E6_dp ) THEN
        WRITE(*,*) 'failed unit conversion for frequency, outside tolerance'
        STOP 1
    ELSE IF ( ABS(energy - 4.5563343515983042E-004) >= 4.5563343515983042E-004/1.0E6_dp ) THEN
        WRITE(*,*) 'failed unit conversion for energy, outside tolerance'
        STOP 1
    END IF

    time = time * convert('au_time','fs')
    beta = 1.0_dp / ( temp * convert('au_energy','kelvin') )
    freq = freq * convert('au_ang_freq','wvnbr')
    energy = energy * convert('au_energy','wvnbr')

END PROGRAM test_unit_conversions


! Some basic testing that calls to the library still work correctly with
! -ff2c
!
! Once the library has support for f2c calling conventions (i.e. passing
! a REAL(kind=4) or COMPLEX-valued intrinsic as procedure argument works), we
! can simply add -ff2c to the list of options to cycle through, and get
! complete coverage.  As of 2005-03-05 this doesn't work.
! { dg-do run }
! { dg-options "-ff2c" }

complex c
double complex d

x = 2.
if ((sqrt(x) - 1.41)**2 > 1.e-4) STOP 1
x = 1.
if ((atan(x) - 3.14/4) ** 2 > 1.e-4) STOP 2
c = (-1.,0.)
if (sqrt(c) /= (0., 1.)) STOP 3
d = c
if (sqrt(d) /= (0._8, 1._8)) STOP 4
end