! Functions for calculating the shape of a distorted star, either due to tides or rotation.
! Based on a multipole expansion of the gravitational potential of the distorted star, as described
! by Kopal (1959) and more recently Landin & al. (2009), A&A 494.
!
! Main differences:
!  1. Do not neglect the contribution of the surface quadrupole momement in the interior.
!     It can become important deep in the stellar interior.
!  2. Due to (1), there are deviations from Radau's equations as given in the literature.
!     In particular, the equation for the l=2 mode is different for rotation and tides.
!  3. Do not assume that rotation is uniform, but assume shellular rotation.
!     This means that the density is also not constant on isobars (TODO).
!
! Simplifying assumptions:
!  1. The tidal potential of the companion is that of a point mass. It should be doable (but cumbersome) to do
!     the full treatment, but it may not be worth it. Certainly the next order (using components of the inertia
!     tensor) should be tried first.
!  2. The expansion is linear in the coefficients of spherical harmonics; higher order terms are ignored.
!  3. The rotation axis is perpendicular to the orbital plane (rotational and orbital angular momentum is aligned).
!     The coordinate system corotates with the orbit, coordinate axes are chosen such that the rotation axis is along
!     the z-direction and the line connecting the two stars is along the x-axis.
!  4. Stars are made up of perfect fluid, so there is no tidal lag and no m != 0 modes.
!     The multipole expansion then reduces to an expansion in Legendre polynomials.
module distortion
   use real_kind
   use constants, only: CPI

   ! Instead of integrating over the full solid angle, we can get away with integrating over only one quarter, since
   ! the rotational perturbation has xy-mirror symmetry and the tidal perturbation has xz-mirror symmetry.
   ! Note that rotation alone would also have xz and yz symmetries, but the yz symmetry is broken by the tides.
   real(double), parameter, private :: theta_min       = 0.0
   real(double), parameter, private :: theta_max       = CPI / 2.0
   real(double), parameter, private :: phi_min         = 0.0
   real(double), parameter, private :: phi_max         = CPI
   real(double), parameter, private :: symmetry_factor = 4.0

   ! Number of steps to take in the phi, theta directions
   ! NB: in the theta direction, we should perhaps use steps that are equidistant in cos(theta) rather than theta
   ! itself...
   integer, parameter, private :: n_theta     = 101
   integer, parameter, private :: n_phi       = 101
   real(double), parameter, private :: dtheta = (theta_max - theta_min) / n_theta
   real(double), parameter, private :: dphi   = (phi_max - phi_min) / n_phi

   ! Values of theta, phi in each direction
   real(double), private, save :: vtheta(n_theta)
   real(double), private, save :: vphi(n_phi)

   ! TODO: test whether it is faster to pre-calculate sine and cosines...

contains

   subroutine initialise_distortion_tables
   implicit none
   integer :: n

   forall(n=1:n_theta) vtheta(n) = (n-1) * (theta_max - theta_min) / (n_theta - 1)
   forall(n=1:n_phi) vphi(n) = (n-1) * (phi_max - phi_min) / (n_phi - 1)

   do n=1, n_theta
      !print *,  n, vtheta(n), asin( real(n-1) / (n_theta-1) )
   end do

   end subroutine initialise_distortion_tables

! ------------------------------------------------------------------------------
! legendrep
! Calculate a Legendre polynomial of degree l, for parameter x.
! ------------------------------------------------------------------------------
! Input:
!  l     - degree of the polynomial (we only implement up to l=5)
!  x     - parameter value
! Returns:
!  The value of the Legendre polynomial
! ------------------------------------------------------------------------------
   elemental function legendrep(l, x)
   implicit none
   integer, intent(in) :: l
   real(double), intent(in) :: x
   real(double) :: legendrep

   legendrep = 1.
   select case (l)
      case (1)
         legendrep = x
      case (2)
         legendrep = 0.5*(3.*x**2 - 1.)
      case (3)
         legendrep = 0.5*(5.*x**3 - 3.*x)
      case (4)
         legendrep = 0.125*(34.*x**4 - 30.*x**2 + 3.)
      case (5)
         legendrep = 0.125*(63.*x**5 - 70.*x**3 + 15.*x)
   end select
   end function legendrep

! ------------------------------------------------------------------------------
! dlegendrep
! Calculate the derivative of a Legendre polynomial of degree l, for parameter x.
! ------------------------------------------------------------------------------
! Input:
!  l     - degree of the polynomial (we only implement up to l=4)
!  x     - parameter value
! Returns:
!  The value of the derivative of the Legendre polynomial
! ------------------------------------------------------------------------------
   elemental function dlegendrep(l, x)
   implicit none
   integer, intent(in) :: l
   real(double), intent(in) :: x
   real(double) :: dlegendrep

   dlegendrep = 0.
   select case (l)
      case (1)
         dlegendrep = 1.
      case (2)
         dlegendrep = 3.*x
      case (3)
         dlegendrep = 1.5*(5.*x*x - 1.)
      case (4)
         dlegendrep = 2.5*(7.*x*x*x - 3.*x)
   end select
   end function dlegendrep

! ------------------------------------------------------------------------------
! intradau
! Integrate Radau's equation for the logarithmic derivative of the spherical
! harmonic.
! ------------------------------------------------------------------------------
! Input:
!  nm          - the number of mesh points, ordered surface (1) to centre (nm)
!  l           - the order of the spherical harmonic
!  rhoratio(:) - ratio of density to average interior density
!  radius0(:)  - average radius of each shell [1e11 cm]
!  dradius0(:) - average thickness of each shell [1e11 cm]
! Ouput:
!  eta(:)      - logarithmic derivative of spherical harmonic at each shell
! ------------------------------------------------------------------------------
   pure subroutine intradau(nm, l, rhoratio, radius0, eta)
   implicit none
   integer, intent(in)        :: nm, l
   real(double), intent(in)   :: rhoratio(nm), radius0(nm)
   real(double), intent(out)  :: eta(nm)
   real(double)               :: dr0
   integer :: n

   ! Central boundary condition value
   eta(nm) = l - 2

   ! Integrate from centre to surface
   ! FIXME: use something better than plain forward Euler, say Runge-Kutta...
   !        The main difficulty is that we'll also need to interpolate the density for that.
   do n = nm-1, 1, -1
      dr0 = radius0(n) - radius0(n+1)
      eta(n) = eta(n+1) + deta(eta(n+1), radius0(n+1), rhoratio(n+1), l) * dr0
   end do

   contains

      ! Right hand side of Radau's equation, for the integration function
      elemental function deta(eta, r0, rhoratio, l)
      implicit none
      real(double), intent(in) :: eta, r0, rhoratio
      integer, intent(in) :: l
      real(double) :: deta
      deta = eta*(eta-1.) + 6.*rhoratio*(1.+eta) - l*(l+1)
      deta = -deta / r0
      end function deta

   end subroutine intradau

! ------------------------------------------------------------------------------
! compute_envelope_integral
! Compute the envelope integral terms that enter in the expression for the
! spherical harmonics.
! ------------------------------------------------------------------------------
! Input:
!  nm          - the number of mesh points, ordered surface (1) to centre (nm)
!  l           - the order of the spherical harmonic
!  rho(:)      - the avarega density on an isobar [g/cm^3]
!  radius0(:)  - average radius of each shell [1e11 cm]
!  alpha(:)    - coefficient of spherical harmonic
!  eta(:)      - logarithmic derivative of spherical harmonic at each shell
! Output:
!  sigma(:)    - envelope integral
! ------------------------------------------------------------------------------
   pure subroutine compute_envelope_integral(nm, l, rho, radius0, alpha, eta, sigma)
   use constants, only: CG, CPI4
   implicit none
   integer, intent(in)       :: nm, l
   real(double), intent(in)  :: rho(nm), radius0(nm), alpha(nm), eta(nm)
   real(double), intent(out) :: sigma(nm)
   real(double) :: dr
   integer :: n

   dr = radius0(2) - radius0(1)
   sigma(1) = rho(1) * radius0(1)**(1 - l)*alpha(1)*(2.-l+eta(1)) * dr

   ! Integrate surface->centre (or gridpoint to surface)
   do n=2, nm
      dr = radius0(n-1) - radius0(n)
      sigma(n) = sigma(n-1) + rho(n) * radius0(n)**(1 - l)*alpha(n)*(2.-l+eta(n)) * dr
   end do

   sigma = sigma * CG * CPI4 / (2.*l + 1)
   end subroutine compute_envelope_integral

! ------------------------------------------------------------------------------
! compute_interior_integral
! Compute the interior integral terms that enter in the expression for the
! spherical harmonics.
! Note that l=0 gives the interior mass
! ------------------------------------------------------------------------------
! Input:
!  nm          - the number of mesh points, ordered surface (1) to centre (nm)
!  l           - the order of the spherical harmonic
!  rho(:)      - the avarega density on an isobar [g/cm^3]
!  radius0(:)  - average radius of each shell [1e11 cm]
!  alpha(:)    - coefficient of spherical harmonic
!  eta(:)      - logarithmic derivative of spherical harmonic at each shell
! Output:
!  mu(:)       - envelope integral
! ------------------------------------------------------------------------------
   pure subroutine compute_interior_integral(nm, l, rho, radius0, alpha, eta, mu)
   use constants, only: CPI4
   implicit none
   integer, intent(in)       :: nm, l
   real(double), intent(in)  :: rho(nm), radius0(nm), alpha(nm), eta(nm)
   real(double), intent(out) :: mu(nm)
   real(double) :: dr
   integer :: n

   dr = radius0(nm) - radius0(nm-1)
   mu(nm) = rho(nm) * radius0(nm)**(2 + l)*alpha(nm)*(3.+l+eta(nm)) * dr

   ! Integrate centre -> surface
   do n=nm-1, 1, -1
      dr = radius0(n) - radius0(n+1)
      mu(n) = mu(n+1) + rho(n) * radius0(n)**(2 + l)*alpha(n)*(3.+l+eta(n)) * dr
   end do

   mu = mu * CPI4 / (2.*l + 1)
   end subroutine compute_interior_integral

! ------------------------------------------------------------------------------
! calculate_distortion_coefficients
! Find the coefficients for the spherical harmonics
! ------------------------------------------------------------------------------
! Input:
!  nm          - the number of mesh points, ordered surface (1) to centre (nm)
!  rho(:)      - the avarega density on an isobar [g/cm^3]
!  radius(:)   - volume radius of the isobar [1e11 cm]
!  r0_guess(:) - Initial guess for the average radius [1e11 cm], could be volume radius
!  mass(:)     - enclosed mass for isobar [1e33 g]
!  omega(:)    - rotation rate for each isobar (shellular rotation) [s^-1]
!  m2          - the mass of the secondary star [1e33 g]
!  a_orb       - the orbital separation between the two stars [1e11 cm]
! Output:
!  r0(:)       - the average radius of each isobar
!  a_rot2(:)   - coefficient of the spherical harmonic for rotation (l=2)
!  a_tide(:,:) - coefficients for tidal terms (l=2,3,4)
!  sigma_rot(:)- exterior integral for rotation (l=2)
!  mu_rot(:)   - interior integral for rotation (l=2)
!  sigma_tide(:,:)- exterior integral for tides (l=2,3,4)
!  mu_tide(:,:)- interior integral for tides (l=2,3,4)
! ------------------------------------------------------------------------------
   pure subroutine calculate_distortion_coefficients(nm, rho, r, m, omega, m2, a_orb, r0, a_rot2, a_tide,&
                                                                                sigma_rot, mu_rot, sigma, mu)
   use constants, only: CG, CPI4, C3RD
   implicit none
   integer, intent(in) :: nm
   real(double), intent(in) :: rho(nm), r(nm), m(nm), omega(nm)
   real(double), intent(in) :: m2, a_orb
   real(double), intent(out) :: r0(nm), a_rot2(nm), a_tide(nm,2:4), mu_rot(nm), mu(nm,2:4), sigma_rot(nm), sigma(nm,2:4)
   real(double) :: q, rho_ratio(nm), eta(nm, 2:4)
   real(double) :: epsilon, delta, a, b, c, d, a2, b2, c2, d2, f3, f
   integer :: iter, n, j

   ! Initialise with default values: undistorted star
   r0 = r
   a_rot2 = 0
   a_tide = 0
   sigma_rot = 0.0
   sigma = 0.0

   ! We are looking for r0, using r as an initial guess (FIXME: we can do better by taking r0 from the previous iteration).
   ! In general we will need to iterate a number of times for the solution to converge.
   do iter=1, 10
      ! Calculate coefficients for Radau's equation
      rho_ratio(:) = rho(:) / ( m(:) / (CPI4*C3RD * r0(:)**3) )
      rho_ratio(nm) = 1.0

      ! Integrate Radau's equations
      ! For now, there's no difference between the l=2 modes for rotation and for tides
      call intradau(nm, 2, rho_ratio, r0, eta(:,2))
      call intradau(nm, 3, rho_ratio, r0, eta(:,3))
      call intradau(nm, 4, rho_ratio, r0, eta(:,4))

      ! Calculate envelope integrals.
      ! We only do this at the second iteration, since values are undefined for the first iteration
      if (iter > 1) then
         call compute_envelope_integral(nm, 2, rho, r0, a_rot2,      eta(:,2), sigma_rot)
         if (m2 > 0.0) then
            call compute_envelope_integral(nm, 2, rho, r0, a_tide(:,2), eta(:,2), sigma(:,2))
            call compute_envelope_integral(nm, 3, rho, r0, a_tide(:,3), eta(:,3), sigma(:,3))
            call compute_envelope_integral(nm, 4, rho, r0, a_tide(:,4), eta(:,4), sigma(:,4))
         end if
      end if

      delta = 0.0

      do n=1, nm
         ! Calculate expansion coefficients

         ! Rotation
         a_rot2(n) = -5./(2. + eta(n, 2)) * (omega(n)**2/3. + sigma_rot(n)) * r0(n)**3/(CG*m(n));

         ! Tides
         if (m2 > 0.0) then
            q = m2/m(n)
            forall (j=2:4) &
               a_tide(n,j) = (2.*j+1.)/(j + eta(n,j)) * q * (r0(n)/a_orb)**(j+1) * (1.0 + sigma(n,j)*a_orb**(1+j)/(CG*m2))
         end if

         ! Calculate average radius from volume radius and the shape of the potential. Test for convergence
         a = -a_rot2(n)
         b =  a_tide(n, 2)
         c =  a_tide(n, 3)
         d =  a_tide(n, 4)
         a2 = a*a;
         b2 = b*b;
         c2 = c*c;
         d2 = d*d;
         f3 = 1.0 + 3./5.*(a2+a*b+b2) + 3.*c2/7.                                                   &
            - 1./35.*(2*a*a2 + 3*b*a2 - 3.*a*b2-2.*a*c2-2*b*b2 - 6.*a*b*c - 6.*b2*d - 4.*b*c2)     &
            + 10./231.*(a*d2 + 2*b*d2)                                                             &
            + 9./140.*a2*d + 6.*c2*d/77 + 18./1001.*d*d2 + d2/3.
         f = f3**C3RD

         ! Change to radius in this iteration
         epsilon = abs(r(n)/f - r0(n))
         if (epsilon > delta) delta = epsilon

         ! Update average radius for next iteration
         r0(n) = r(n) / f
      end do
      !print *, iter, delta
      if (delta < 1.0e-12) exit
   end do

   ! Calculate interior integrals
   mu_rot = 0.0
   mu = 0.0
   !call compute_interior_integral(nm, 2, rho, r0, a_rot2,      eta(:,2), mu_rot)
   !call compute_interior_integral(nm, 2, rho, r0, a_tide(:,2), eta(:,2), mu(:,2))
   !call compute_interior_integral(nm, 3, rho, r0, a_tide(:,3), eta(:,3), mu(:,3))
   !call compute_interior_integral(nm, 4, rho, r0, a_tide(:,4), eta(:,4), mu(:,4))
   end subroutine calculate_distortion_coefficients

! ------------------------------------------------------------------------------
! calculate_effective_gravity
! Calculate the average effective gravity <g> and its inverse <1/g> over an
! isobar, as well as the surface area of the isobar.
! To rotational component is invariant under reflection in the xy, xz and yz
! planes, but the tidal component is asymmetric along the x-axis. This means
! we can break up the integration domain in 4 equal parts and integrate the
! azimuthal angle phi from 0 to pi and the polar angle theta from 0 to pi/2.
! ------------------------------------------------------------------------------
! Input:
!  nm            - the number of mesh points, ordered surface (1) to centre (nm)
!  radius(:)     - volume radius of the isobar [1e11 cm]
!  mass(:)       - enclosed mass for isobar [1e33 g]
!  omega(:)      - rotation rate for each isobar (shellular rotation) [s^-1]
!  m2            - the mass of the secondary star [1e33 g]
!  a_orb         - the orbital separation between the two stars [1e11 cm]
!  r0(:)         - the average radius of each isobar
!  a_rot2(:)     - coefficient of the spherical harmonic for rotation (l=2)
!  a_tide(:,:)   - coefficients for tidal terms (l=2,3,4)
!  sigma_rot2(:) - envelope integral for rotation (l=2)
!  gamma_rot2(:) - interior integral for rotation (l=2)
!  sigma_tide(:) - envelope integral for tides (l=2,3,4)
!  gamma_tide(:) - interior integral for tides (l=2,3,4)
! Output:
!  avgg(:)       - effective gravity over an isobar (cm / s^2)
!  invg(:)       - inverse effective gravity over an isobar (cm / s^2)
!  spsi(:)       - surface area of an isobar (1e22 cm^2)
!  fp(:)         - correction factor fp [-]
!  ft(:)         - correction factor ft [-]
! ------------------------------------------------------------------------------
   pure subroutine calculate_effective_gravity(nm, ra, ma, omega, m2, a_orb, r0a, a_rot2, a_tide,&
                                               sigma_rot2, gamma_rot2, sigma_tidea, gamma_tidea, avgg, invg, spsi, fp, ft)
   use constants, only: CG, CPI4
   implicit none
   integer, intent(in) :: nm
   real(double), intent(in) :: ra(nm), ma(nm), omega(nm)
   real(double), intent(in) :: m2, a_orb
   real(double), intent(in) :: a_rot2(nm), a_tide(nm,2:4), r0a(nm)
   real(double), intent(in) :: sigma_rot2(nm), gamma_rot2(nm), sigma_tidea(nm,2:4), gamma_tidea(nm,2:4)
   real(double), intent(out) :: avgg(nm), invg(nm), spsi(nm), fp(nm), ft(nm)
   real(double) :: a_orb2, omega2, theta, phi, cos_chi, rr, r2, r3, r4, dspsi, dpsi_dr, dpsi_dtheta, dpsi_dphi, fac, facr, gg
   real(double) :: sigma_rot, mu_rot, sigma_tide(2:4), mu_tide(2:4), a2, a(2:4), r, m, r0
   real(double) :: cos_theta, sin_theta, dcos_theta, cos_phi, sin_phi
   integer :: n, nt, np

   a_orb2 = a_orb*a_orb
   do n = 1, nm
      spsi(n) = 0.0
      avgg(n) = 0.0
      invg(n) = 0.0
      omega2 = omega(n)**2

      ! Copy integrals and coefficients to local variables, oterwise we keep hammering the processor cache
      sigma_rot       = sigma_rot2(n)
      mu_rot          = gamma_rot2(n)
      sigma_tide(2:4) = sigma_tidea(n, 2:4)
      mu_tide(2:4)    = gamma_tidea(n, 2:4)
      a2              = a_rot2(n)
      a(2:4)          = a_tide(n, 2:4)
      r0              = r0a(n)
      m               = ma(n)
      r               = ra(n)
      do nt=1, n_theta
         theta = (nt-1)*dtheta
         cos_theta  = cos(theta)
         sin_theta  = sin(theta)
         dcos_theta = cos_theta - cos(theta+dtheta)
         do np=1, n_phi
            phi = (np-1)*dphi
            cos_phi = cos(phi)
            sin_phi = sin(phi)
            cos_chi = cos_phi*sin_theta

            ! Calculate the radial coordinate of the isobar in this direction
            rr = 1.0 + a2 * legendrep(2, cos_theta) &
                     + a(2)*legendrep(2,cos_chi) + a(3)*legendrep(3,cos_chi) + a(4)*legendrep(4,cos_chi)
            rr = r0*rr
            r2 = rr*rr
            r3 = r2*rr
            r4 = r3*rr

            ! Surface element
            dspsi = r2 * dcos_theta*dphi
            spsi(n) = spsi(n) + dspsi

            ! Gradient of pseudo potential
            dpsi_dr     = CG*m/r2 - 2.*omega2*rr/3. &
                           -(-3.*CG*mu_rot/r3 + 2.*rr*sigma_rot - 2.*omega2*rr/3.) * legendrep(2, cos_theta)
            dpsi_dtheta = (CG*mu_rot/r3 + r2*sigma_rot - omega2*r2/3.) * dlegendrep(2, cos_theta) * sin_theta
            dpsi_dphi   = 0;

            ! Unroll the following loop manually; for some reason the Intel compiler does an appalling job with this loop,
            ! making it take much longer than it normally should.
            !do j = 2, 4
            !   fac  = CG*mu_tide(j)/rr**(j+1) + rr**j*sigma_tide(j) + CG*m2/a_orb*(rr/a_orb)**j
            !   facr = -(j+1)*CG*mu_tide(j)/rr**(j+2) + j*rr**(j-1)*sigma_tide(j) + j*CG*m2/a_orb2*(rr/a_orb)**(j-1)
            !   dpsi_dr     = dpsi_dr     - facr * legendrep(j, cos_chi)
            !   dpsi_dtheta = dpsi_dtheta + fac  * dlegendrep(j,cos_chi)*cos(phi)*cos(theta)
            !   dpsi_dphi   = dpsi_dphi   + fac  * dlegendrep(j,cos_chi)*sin(theta)*sin(phi)
            !end do
            fac  = CG*mu_tide(2)/r3 + r2*sigma_tide(2) + CG*m2/a_orb*(rr/a_orb)**2
            facr = -(2+1)*CG*mu_tide(2)/r4 + 2*rr*sigma_tide(2) + 2*CG*m2/a_orb2*(rr/a_orb)**(2-1)
            dpsi_dr     = dpsi_dr     - facr * legendrep(2, cos_chi)
            dpsi_dtheta = dpsi_dtheta + fac  * dlegendrep(2,cos_chi)*cos_phi*cos_theta
            dpsi_dphi   = dpsi_dphi   + fac  * dlegendrep(2,cos_chi)*sin_theta*sin_phi

            fac  = CG*mu_tide(3)/r4 + r3*sigma_tide(3) + CG*m2/a_orb*(rr/a_orb)**3
            facr = -(3+1)*CG*mu_tide(3)/(rr*r4) + 3*r2*sigma_tide(3) + 3*CG*m2/a_orb2*(rr/a_orb)**(3-1)
            dpsi_dr     = dpsi_dr     - facr * legendrep(3, cos_chi)
            dpsi_dtheta = dpsi_dtheta + fac  * dlegendrep(3,cos_chi)*cos_phi*cos_theta
            dpsi_dphi   = dpsi_dphi   + fac  * dlegendrep(3,cos_chi)*sin_theta*sin_phi

            fac  = CG*mu_tide(4)/(rr*r4) + r4*sigma_tide(4) + CG*m2/a_orb*(rr/a_orb)**4
            facr = -(4+1)*CG*mu_tide(4)/(r2*r4) + 4*r3*sigma_tide(4) + 4*CG*m2/a_orb2*(rr/a_orb)**(4-1)
            dpsi_dr     = dpsi_dr     - facr * legendrep(4, cos_chi)
            dpsi_dtheta = dpsi_dtheta + fac  * dlegendrep(4,cos_chi)*cos_phi*cos_theta
            dpsi_dphi   = dpsi_dphi   + fac  * dlegendrep(4,cos_chi)*sin_theta*sin_phi

            ! Gravity
            ! Avoid a singularity at theta=0, at which point the phi-dependent terms vanish analytically
            if (nt > 1) then
               gg = sqrt(dpsi_dr*dpsi_dr + dpsi_dtheta*dpsi_dtheta/r2 + dpsi_dphi*dpsi_dphi/(rr*sin_theta)**2)
            else
               gg = sqrt(dpsi_dr*dpsi_dr + dpsi_dtheta*dpsi_dtheta/r2)
            end if
            avgg(n) = avgg(n) + dspsi * gg
            invg(n) = invg(n) + dspsi / gg
         end do
      end do
      avgg(n) = avgg(n) / spsi(n)
      invg(n) = invg(n) / spsi(n)
      spsi(n) = spsi(n) * symmetry_factor

      ! Calculate correction factors fp and ft
      r2 = r*r
      fp(n) = CPI4 * r2*r2 / (CG*m * spsi(n) * invg(n))
      ft(n) = (CPI4*r2 / spsi(n))**2 / (avgg(n)*invg(n))

      ! Due to rounding errors, fp or ft can be > 1 (just about), which is unphysical
      fp(n) = min(fp(n), 1.0d0)
      ft(n) = min(ft(n), 1.0d0)

      ! Convert to CGS units
      avgg(n) = avgg(n) * 1.0e11
      invg(n) = invg(n) / 1.0e11
   end do
   end subroutine calculate_effective_gravity

end module distortion


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZEXROU (Zomplex EXample Known EigenValues)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine chooses N random eigenvalues on the unit
! circle, constructs a unitary matrix with prescribed
! eigenvalues, and computes the N eigenvalues by solving
! a corresponding unitary eigenvalue problem two different
! ways.
!
! 1) Form upper Hessenberg permutation matrix and compute its
!    eigenvalues using ZUHFQR
!
! 2) Construct the factorization directly and compute its
!    eigenvalues using ZUFFQR
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program ZEXKEV

  implicit none

  ! compute variables
  integer, parameter :: N = 16
  integer :: ii, INFO
  real(8) :: WORK(5*N), Q(3*(N-1)), D(2*N)
  complex(8) :: H(N,N), Z, he, temp(2,2)
  integer :: ITS(N-1), ind, jj
  double precision :: rm,ro,rp,pi = 3.141592653589793239d0
  double precision :: diff, her
  double precision :: nrm,b1(3),b2(3),b3(3),tb(3),tol=1e-16

  ! real and imag part of eigenvalues
  double precision :: rev(N), iev(N)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! print banner
  print*,""
  print*,"ZEXKEV: Zomple EXample Known EigenValues"
  print*,""

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! initialize Q and D to be an identity matrix
  Q = 0d0
  D = 0d0
  do ii=1,n-1
     Q(3*ii-2) = 1d0
     D(2*ii-1) = 1d0
  end do
  D(2*n-1) = 1d0

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! random eigenvalues, on the unit circle
  do ii = 1,n,2
     call random_number(rm)
     rev(ii) = sin(2*pi*rm)
     iev(ii) = cos(2*pi*rm)
     ! project on the unit circle
     nrm = rev(ii)**2+iev(ii)**2
     if (abs(nrm-1)<tol) then
        nrm = sqrt(nrm)
        rev(ii) = rev(ii)/nrm
        iev(ii) = iev(ii)/nrm
     end if
     Q(3*ii-2) = rev(ii)
     Q(3*ii)   = iev(ii)
     rev(ii+1) = rev(ii)
     iev(ii+1) = -iev(ii)
  end do

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! inverse eigenvalue problem
  do ii=n-3,1,-2
     ! generate random bulge
     call random_number(rp)
     call random_number(ro)
     call random_number(rm)
     call ZARCG33(rm,ro,rp,b1(1),b1(2),b1(3),NRM,INFO)
     call random_number(rp)
     call random_number(ro)
     call random_number(rm)
     call ZARCG33(rm,ro,rp,b2(1),b2(2),b2(3),NRM,INFO)
     ! fuse on the top of the current Q sequence
     tb(1) = b2(1)
     tb(2) = -b2(2)
     tb(3) = -b2(3)
     b3(1) = b1(1)
     b3(2) = -b1(2)
     b3(3) = -b1(3)
     ind = 3*(ii-1)
     call ZARGTO(tb,b3,Q((ind+1):(ind+3)),INFO)
     Q((ind+4):(ind+6)) = b3
     b3 = Q((ind+1):(ind+3))
     Q((ind+1):(ind+3)) = tb
     ! main chasing loop
     do jj=ii,(n-3)
        ! set indices
        ind = 3*(jj-1)
        ! through diag
        call ZARGTD('R',D(2*jj+1:2*jj+4),b1,INFO)
        call ZARGTO(Q((ind+4):(ind+6)),Q((ind+7):(ind+9)),b1,INFO)
        call ZARGTD('R',D(2*jj-1:2*jj+2),b2,INFO)
        call ZARGTO(Q((ind+1):(ind+3)),Q((ind+4):(ind+6)),b2,INFO)
        call ZARGTO(b3,b1,b2,INFO)
        ! update bulges
        tb = b2
        b2 = b3
        b3 = b1
        b1 = tb
     end do
     ind = 3*(n-3)
     ! fusion at bottom
     call ZUFFGR('B',N,ii,N-1,Q,D,b1,INFO)
     call ZARGTD('R',D(2*n-5:2*n-2),b2,INFO)
     call ZARGTO(Q((ind+1):(ind+3)),Q((ind+4):(ind+6)),b2,INFO)
     call ZUFFGR('B',N,ii,N-1,Q,D,b3,INFO)
     call ZUFFGR('B',N,ii,N-1,Q,D,b2,INFO)
  end do

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! initialize H to be an upper Hessenberg permutation matrix
  H = 0d0
  do ii=1,N
     H(ii,ii)=1d0
  end do
  H(1,1) = cmplx(Q(1),Q(2),kind=8)
  H(1,2) = Q(3)
  H(2,1) = -Q(3)
  H(2,2) = cmplx(Q(1),-Q(2),kind=8)
  do ii=2,N-1
     temp(1,1) = cmplx(Q(3*ii-2),Q(3*ii-1),kind=8)
     temp(1,2) = Q(3*ii)
     temp(2,1) = -Q(3*ii)
     temp(2,2) = cmplx(Q(3*ii-2),-Q(3*ii-1),kind=8)
     do jj = 1,ii+1
        he = H(jj,ii)*temp(1,1) + H(jj,ii+1)*temp(2,1)
        H(jj,ii+1) = H(jj,ii)*temp(1,2) + H(jj,ii+1)*temp(2,2)
        H(jj,ii) = he
     end do
  end do
  do ii=1,N
     H(:,ii) = H(:,ii)*cmplx(D(2*ii-1),D(2*ii),kind=8)
  end do

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  print*,"Eigenvalues:"
  do ii=1,N
     print*, rev(ii), iev(ii)
  end do
  print*,""

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! call dohfqr
  call ZUHFQR('N',N,H,Z,ITS,WORK,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"ZUHFQR failed."
    print*,"INFO:",INFO
  end if

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! print diag of H
  print*,"Eigenvalues computed using ZUHFQR: (real part, imag part, distance to closest exact eigenvalue)"
  do ii=1,N
     diff = sqrt(abs(dble(H(ii,ii))-rev(1))**2+abs(aimag(H(ii,ii))-iev(1))**2)
     do jj=2,N
        her = sqrt(abs(dble(H(ii,ii))-rev(jj))**2+abs(aimag(H(ii,ii))-iev(jj))**2)
        if (her < diff) then
           diff = her
        end if
     end do
     print*,dble(H(ii,ii)),aimag(H(ii,ii)),diff
  end do
  print*,""

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! call doffqr
  call ZUFFQR('N',N,Q,D,Z,ITS,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"ZUFFQR failed."
    print*,"INFO:",INFO
  end if

  ! print D
  print*,"Eigenvalues computed using ZUFFQR: (real part, imag part, distance to closest exact eigenvalue)"
  do ii=1,N
     diff = sqrt(abs(D(2*ii-1)-rev(1))**2+abs(D(2*ii)-iev(1))**2)
     do jj=2,N
        her = sqrt(abs(D(2*ii-1)-rev(jj))**2+abs(D(2*ii)-iev(jj))**2)
        if (her < diff) then
           diff = her
        end if
     end do
     print*,D(2*ii-1),D(2*ii), diff
  end do
  print*,""

end program ZEXKEV


module tensor_nmode
implicit none

contains

function n_mode(mode, gdim, newsize, core, spp) result(tenprod)
    integer, intent(in) :: mode
    integer, intent(in) :: newsize
    integer, dimension(:), intent(in) :: gdim
    real, dimension(:), intent(in) :: spp
    real, dimension(product(gdim)), intent(in) :: core
    real, dimension(newsize) :: tenprod

    integer, dimension(2) :: newshape

    if (gdim(mode) == 0) then
        tenprod = dot_product(core, spp)
    else
        newshape = (/newsize, gdim(mode)/)
        tenprod = matmul(reshape(core, newshape), spp)
    end if

end function n_mode

end module tensor_nmode


subroutine Jacobian(parameters,J)
    use nrtype; use dimensions; use optimization; use pdfs;use structural_p2;use grids;use targets
    implicit none
    real(SP),dimension(moment_conditions,parameters_to_est),intent(out)::J
    real(SP),dimension(parameters_to_est),intent(in)::parameters
    real(SP),dimension(parameters_to_est,2)::parameters_new
    real(SP),dimension(moment_conditions,1)::moments,densities,moments_nom,densities_nom
    real(SP),dimension(moment_conditions,2)::moments_new,densities_new,moments_new_nom
    integer::i_l,p_l,m_l
    real(SP),dimension(parameters_to_est)::eps
    character::pause_k
    J=0.0_sp
    call SMM_se(parameters,moments,densities)
    do i_l=1,moment_conditions
        if (data_moments(i_l,1)==-9.0_sp) then
            moments(i_l,1)=-9.0_sp
            densities(i_l,1)=-9.0_sp
        end if
        if (isnan(densities(i_l,1))) then
            print*,'something bad in jacobian',i_l
            read*,pause_k
        end if
    end do

    call empty_missing(moments,moments_nom,int(moment_conditions),real_moments)
    call empty_missing(densities,densities_nom,int(moment_conditions),real_moments)

    eps=0.01_sp

    do p_l=1,parameters_to_est
        do m_l=1,2
            parameters_new(:,m_l)=parameters
            if (m_l==1)then
                parameters_new(p_l,m_l)=parameters_new(p_l,m_l)+eps(p_l)
            else
                parameters_new(p_l,m_l)=parameters_new(p_l,m_l)-eps(p_l)
            end if
            call SMM_se(parameters_new(:,m_l),moments_new(:,m_l),densities_new(:,m_l))
            do i_l=1,moment_conditions
                if (data_moments(i_l,1)==-9.0_sp) then
                    moments_new(i_l,m_l)=-9.0_sp
                end if
            end do
            call empty_missing(moments_new(:,m_l),moments_new_nom(:,m_l),int(moment_conditions),real_moments)
        end do
        J(1:real_moments,p_l)=(moments_new_nom(1:real_moments,1)-moments_new_nom(1:real_moments,2))/(parameters_new(p_l,1)-parameters_new(p_l,2))*densities_nom(1:real_moments,1)
        print*,'p_l',p_l
        print*,'J(:,p_l)',J(1:real_moments,p_l)
    end do

end subroutine


c  Part of R package KernSmooth
c  Copyright (C) 1995  M. P. Wand
c
c  Unlimited use and distribution (see LICENCE).

cccccccc FORTRAN subroutine blkest.f cccccccccc

c     For computing blocked polynomial estimates
c     required for the direct plug-in bandwidth
c     selector of Ruppert, Sheather and Wand.

c     Last changed: 26/04/95

      subroutine blkest(X,Y,n,q,qq,Nval,Xj,Yj,coef,Xmat,wk,qraux,
     +                  sigsqe,th22e,th24e)

      integer n,q,qq,Nval,nj,i,j,k,idiv,ilow,iupp,info
      double precision RSS,X(n),Y(n),Xj(n),Yj(n),coef(qq),wk(n),
     +                 Xmat(n,qq),qraux(qq),fiti,th22e,th24e,sigsqe,
     +                 ddm,ddddm,work(1)

c     It is assumed that the (X,Y) data are
c     sorted with respect to the X's.
      RSS = 0.0d0
      th22e = 0.0d0
      th24e = 0.0d0
      idiv = n/Nval
      do 10 j = 1,Nval

c        For each member of the partition

         ilow = (j-1)*idiv + 1
         iupp = j*idiv
         if (j.eq.Nval) iupp = n
         nj = iupp - ilow + 1
         do 20 k = 1,nj
            Xj(k) = X(ilow+k-1)
            Yj(k) = Y(ilow+k-1)
20       continue

c        Obtain a q'th degree fit over current
c        member of partition

c        Set up "X" matrix

         do 30 i = 1,nj
            Xmat(i,1) = 1.0d0
            do 40 k = 2,qq
               Xmat(i,k) = Xj(i)**(k-1)
40          continue
30          continue

            call dqrdc(Xmat,n,nj,qq,qraux,0,work,0)
            info=0
            call dqrsl(Xmat,n,nj,qq,qraux,Yj,wk,wk,coef,wk,wk,
     +                 00100,info)

            do 50 i = 1,nj
               fiti = coef(1)
               ddm = 2*coef(3)
               ddddm = 24*coef(5)
               do 60 k = 2,qq
                  fiti = fiti + coef(k)*Xj(i)**(k-1)
                  if (k.le.(q-1)) then
                     ddm = ddm + k*(k+1)*coef(k+2)*Xj(i)**(k-1)
                     if (k.le.(q-3)) then
                        ddddm = ddddm +
     +                  k*(k+1)*(k+2)*(k+3)*coef(k+4)*Xj(i)**(k-1)
                     endif
                  endif
60             continue
               th22e = th22e + ddm**2
               th24e = th24e + ddm*ddddm
               RSS = RSS + (Yj(i)-fiti)**2
50          continue
10       continue

      sigsqe = RSS/(n-qq*Nval)
      th22e = th22e/n
      th24e = th24e/n

      return
      end

cccccccccc End of blkest.f cccccccccc


      SUBROUTINE REVCST(X,Y,IORDER,NCITY,N,DE)
C Rev. 12/13/85
      DIMENSION X(NCITY),Y(NCITY),IORDER(NCITY),N(6),XX(4),YY(4)
      ALEN(X1,X2,Y1,Y2)=SQRT((X2-X1)**2+(Y2-Y1)**2)
      N(3)=1+MOD((N(1)+NCITY-2),NCITY)
      N(4)=1+MOD(N(2),NCITY)
      DO 11 J=1,4
          II=IORDER(N(J))
          XX(J)=X(II)
          YY(J)=Y(II)
11    CONTINUE
      DE=-ALEN(XX(1),XX(3),YY(1),YY(3))-ALEN(XX(2),XX(4),YY(2),YY(4))
     *     +ALEN(XX(1),XX(4),YY(1),YY(4))+ALEN(XX(2),XX(3),YY(2),YY(3))
      RETURN
      END

      SUBROUTINE REVERS(IORDER,NCITY,N)
      DIMENSION IORDER(NCITY),N(6)
      NN=(1+MOD(N(2)-N(1)+NCITY,NCITY))/2
      DO 11 J=1,NN
          K=1+MOD((N(1)+J-2),NCITY)
          L=1+MOD((N(2)-J+NCITY),NCITY)
          ITMP=IORDER(K)
          IORDER(K)=IORDER(L)
          IORDER(L)=ITMP
11    CONTINUE
      RETURN
      END

      SUBROUTINE TRNCST(X,Y,IORDER,NCITY,N,DE)
      DIMENSION X(NCITY),Y(NCITY),IORDER(NCITY),N(6),XX(6),YY(6)
      ALEN(X1,X2,Y1,Y2)=SQRT((X2-X1)**2+(Y2-Y1)**2)
      N(4)=1+MOD(N(3),NCITY)
      N(5)=1+MOD((N(1)+NCITY-2),NCITY)
      N(6)=1+MOD(N(2),NCITY)
      DO 11 J=1,6
          II=IORDER(N(J))
          XX(J)=X(II)
          YY(J)=Y(II)
11    CONTINUE
      DE=-ALEN(XX(2),XX(6),YY(2),YY(6))-ALEN(XX(1),XX(5),YY(1),YY(5))
     *     -ALEN(XX(3),XX(4),YY(3),YY(4))+ALEN(XX(1),XX(3),YY(1),YY(3))
     *     +ALEN(XX(2),XX(4),YY(2),YY(4))+ALEN(XX(5),XX(6),YY(5),YY(6))
      RETURN
      END

      SUBROUTINE TRNSPT(IORDER,NCITY,N)
      PARAMETER(MAXCIT=1000)
      DIMENSION IORDER(NCITY),JORDER(MAXCIT),N(6)
      M1=1+MOD((N(2)-N(1)+NCITY),NCITY)
      M2=1+MOD((N(5)-N(4)+NCITY),NCITY)
      M3=1+MOD((N(3)-N(6)+NCITY),NCITY)
      NN=1
      DO 11 J=1,M1
          JJ=1+MOD((J+N(1)-2),NCITY)
          JORDER(NN)=IORDER(JJ)
          NN=NN+1
11    CONTINUE
      IF (M2.GT.0) THEN
          DO 12 J=1,M2
              JJ=1+MOD((J+N(4)-2),NCITY)
              JORDER(NN)=IORDER(JJ)
              NN=NN+1
12        CONTINUE
      ENDIF
      IF (M3.GT.0) THEN
          DO 13 J=1,M3
              JJ=1+MOD((J+N(6)-2),NCITY)
              JORDER(NN)=IORDER(JJ)
              NN=NN+1
13        CONTINUE
      ENDIF
      DO 14 J=1,NCITY
          IORDER(J)=JORDER(J)
14    CONTINUE
      RETURN
      END

      SUBROUTINE METROP(DE,T,ANS)
      PARAMETER(JDUM=1)
      LOGICAL ANS
      ANS=(DE.LT.0.0).OR.(RAN3(JDUM).LT.EXP(-DE/T))
      RETURN
      END


      SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct and solve a linear algebraic system of order M whose
C     coefficient matrix is in upper Hessenberg form. Such systems
C     appear when solving Sylvester equations using the Hessenberg-Schur
C     method.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix B.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix A.  M >= 0.
C
C     IND     (input) INTEGER
C             The index of the column in C to be computed.  IND >= 1.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain an
C             upper Hessenberg matrix.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading N-by-N part of this array must contain a
C             matrix in real Schur form.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the coefficient matrix C of the equation.
C             On exit, the leading M-by-N part of this array contains
C             the matrix C with column IND updated.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     Workspace
C
C     D       DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M)
C
C     IPR     INTEGER array, dimension (2*M)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             > 0:  if INFO = IND, a singular matrix was encountered.
C
C     METHOD
C
C     A special linear algebraic system of order M, with coefficient
C     matrix in upper Hessenberg form is constructed and solved. The
C     coefficient matrix is stored compactly, row-wise.
C
C     REFERENCES
C
C     [1] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur method for the problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and
C     C. Van Loan, Stanford University, California, United States of
C     America, January 1982.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, IND, LDA, LDB, LDC, M, N
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(*)
C     .. Local Scalars ..
      INTEGER           I, I2, J, K, K1, K2, M1
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, SB04MW
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      DO 20 I = IND + 1, N
         CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 )
   20 CONTINUE
C
      M1 = M + 1
      I2 = ( M*M1 )/2 + M1
      K2 = 1
      K  = M
C
C     Construct the linear algebraic system of order M.
C
      DO 40 I = 1, M
         J = M1 - K
         CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 )
         K1 = K2
         K2 = K2 + K
         IF ( I.GT.1 ) THEN
            K1 = K1 + 1
            K  = K - 1
         END IF
         D(K1) = D(K1) + B(IND,IND)
C
C        Store the right hand side.
C
         D(I2) = C(I,IND)
         I2 = I2 + 1
   40 CONTINUE
C
C     Solve the linear algebraic system and store the solution in C.
C
      CALL SB04MW( M, D, IPR, INFO )
C
      IF ( INFO.NE.0 ) THEN
         INFO = IND
      ELSE
C
         DO 60 I = 1, M
            C(I,IND) = D(IPR(I))
   60    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of SB04MY ***
      END


      SUBROUTINE TRANS(Y,A,X)
      DIMENSION  Y(10), A(10), X(10)
	COMMON /NLCPAR/XC(10), N, FIXSEP
	LOGICAL FIXSEP
C----- TRANSOFRMATION FOR GAUSSIAN LINES
C
C----- 'N' GAUSSIAN LINES
C
	Y(1)=EXP(-0.5*((X(1)-XC(1)-A(2))/A(1))**2)
	DO 1000 I=2,N
		IF(FIXSEP) THEN
			DELTA=A(2)
		ELSE
			DELTA=A(2*I)
		ENDIF
		Y(1)=Y(1)+ABS(A(2*I-1)*EXP(-0.5*((X(1)-XC(I)-DELTA)/
     *                        A(1))**2))
1000	CONTINUE
C
      RETURN
      END


*
*     ------------------------------------------------------------------
*       R M E T R
*     ------------------------------------------------------------------
*
* --- evaluates the angular part of the one-electron transition reduced
*     matrix element. See equations (4) and (5) of paper II.
*
      DOUBLE PRECISION FUNCTION RMETR(L1,L2)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL REL,VOK
      COMMON /EMS/IEM(4),IFL,JI,JF,LAM,REL,VOK
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      IF(IFL.EQ.1) THEN
*       electric multipole transitions
        RMETR=RME(L1,L2,LAM)
	IF(MOD(L2-L1+LAM,4).NE.0) RMETR=-RMETR
      ELSE
*       magnetic multipole transitions
        RMETR=RME(L1,L2,LAM-1)
        IF(DABS(RMETR).GT.EPS) THEN
	  IF(MOD(L2-L1+LAM-1,4).NE.0) RMETR=-RMETR
          IF(IFL.EQ.3) THEN
            LL2=L2+L2
            L3=LAM+LAM
	    CALL SIXJ(2,LL2,LL2,L1+L1,L3,L3-2,1,W)
            RMETR=-RMETR*W*SQRT(DBLE(L2*(L2+1)*(LL2+1)*(L3+1)))
          ELSE
            RMETR=RMETR*SQRT(HALF*THREE)
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END


!----------------------------------------------------------------------------- best with 100 columns

!> environment for fepic
module modFEPIC
  use modParticle
  use modPICGrid
  use modCondition
  use modSUNDIALS
  use modSparse
  use modSource

  public

  integer,parameter::DIMS=3 !< three dimensions

  double precision,parameter::AMU=1.6605390666050d-27 !< atomic mass unit (Dalton) [kg]
  double precision,parameter::QE=1.602176634d-19 !< elementary charge [C]
  double precision,parameter::EPS0=8.85418782d-12 !< vacuum permittivity [F/m]

  integer,parameter::BC_PHI_DEFAULT=0 !< default phi BC: Neumann with zero normal phi gradient
  integer,parameter::BC_PHI_DIRICHLET=1 !< Dirichlet BC with given potential

  integer,parameter::BC_PTCL_DEFAULT=0 !< default particle BC: removed upon impact

  integer,parameter::PHI_PREC_LFILL=50 !< phi equation ILU preconditioning fill limit

  integer::iProc,nProc,ierr !< mpi variables

  type(ptcls),allocatable::p(:) !< particles of each species
  type(PICGrid)::grid !< the grid
  type(condTab)::phibc !< electric field boundary conditions
  type(condTab)::ptclbc !< particle boundary conditions
  type(NewtonKrylov)::phiEq !< non-linear FEM phi equation
  type(ILU)::phiLinEq !< linearized FEM phi equation
  type(ILU)::negLaPhi !< negative Laplacian of phi (phiLinEq but without electron model part)
  type(pSrc),allocatable::ptclSrc(:) !< particle source

  integer::nSp !< number of particle species

  double precision,allocatable::phi(:) !< electric potential [V]
  double precision,allocatable::ef(:,:) !< electric field strength [V/m]
  double precision,allocatable::rhsPhi(:) !< RHS of the phi equation [C], and [V] (Dirichlet nodes)
  double precision,allocatable::rhsPhiDi(:) !< RHS of the phi equation, only Dirichlet nodes [V]
  double precision,allocatable::qDepoLocal(:) !< discretized ionDensity/EPS0, local version [C]
  double precision,allocatable::qDepo(:) !< discretized ionDensity/EPS0, reduced version [C]
  double precision,allocatable::den(:,:) !< species density [m^-3]
  double precision,allocatable::denLocal(:,:) !< species density, local version [m^-3]
  double precision,allocatable::wallIDen(:) !< wall hit current density [A/m^2]
  double precision,allocatable::wallHitDenLocal(:) !< wall hit charge density, local version [C/m^2]
  double precision,allocatable::nVol(:) !< FEM nodal volume
  integer,allocatable::iPhiBC(:) !< indexes of electric field boundary conditions
  integer,allocatable::iPtclBC(:) !< indexes of particle boundary conditions
  logical,allocatable::isDirichlet(:) !< whether a point is a Dirichlet point

  double precision::t !< current time [s]
  double precision::dt !< time step size [s]
  double precision::tFinal !< total simulation time [s]

  double precision::tOutNext !< time to write the next output [s]
  double precision::dtOut !< interval to write output [s]
  integer::iOut !< output index
  integer::nAvgOut !< number of time steps for averaged output

  ! Boltzmann relationship electron model parameters
  double precision::ne0BR !< reference electron density [m^-3]
  double precision::phi0BR !< reference electric potential [V]
  double precision::kbTeBR !< electron temperature [eV]

contains

  !> initialize the simulation
  subroutine init()
    use modFileIO
    use modCondition
    use modSparse
    use modBasicFEM
    use modSource
    integer,parameter::FID=10
    double precision::mass,charge

    ! read grid
    open(FID,file='grid.msh',action='read')
      call readGMSH(FID,grid)
    close(FID)
    call grid%up()

    ! read particle species
    open(FID,file='ptclSp',action='read')
      read(FID,*)nSp
      allocate(p(nSp))
      do i=1,nSp
        read(FID,*)
        read(FID,*)mass
        read(FID,*)charge
        call p(i)%init(mass*AMU,charge*QE)
      end do
    close(FID)

    ! work space
    allocate(phi(grid%nN))
    allocate(rhsPhi(grid%nN))
    allocate(rhsPhiDi(grid%nN))
    allocate(qDepoLocal(grid%nN))
    allocate(qDepo(grid%nN))
    allocate(den(grid%nN,size(p)))
    allocate(denLocal(grid%nN,size(p)))
    allocate(wallIDen(grid%nE))
    allocate(wallHitDenLocal(grid%nE))
    allocate(nVol(grid%nN))
    allocate(isDirichlet(grid%nN))
    allocate(ef(3,grid%nN))

    ! read particle sources
    open(FID,file='ptclSrc',action='read')
      read(FID,*)n
      allocate(ptclSrc(n))
      do i=1,n
        call ptclSrc(i)%load(FID)
      end do
    close(FID)

    ! read electric field BCs
    open(FID,file='phiBC',action='read')
      call readCondTab(FID,phibc)
    close(FID)
    call mapCondTab(grid,phibc,iPhiBC)
    rhsPhiDi(:)=0d0
    isDirichlet(:)=.false.
    do i=grid%nC+1,grid%nE
      if(iPhiBC(i)>0)then
        select case(phibc%t(iPhiBC(i)))
        case(BC_PHI_DIRICHLET) !< Dirichlet with given phi
          do j=1,grid%nNE(i)
            isDirichlet(grid%iNE(j,i))=.true.
            rhsPhiDi(grid%iNE(j,i))=phibc%p(1,iPhiBC(i))
          end do
        case default
        end select
      end if
    end do

    ! read particle BCs
    open(FID,file='ptclBC',action='read')
      call readCondTab(FID,ptclbc)
    close(FID)
    call mapCondTab(grid,ptclbc,iPtclBC)

    ! read electron model parameters
    open(FID,file='eMod',action='read')
      read(FID,*)ne0BR
      read(FID,*)phi0BR
      read(FID,*)kbTeBR
    close(FID)

    ! read simulation parameters
    open(FID,file='sim',action='read')
      read(FID,*)tFinal
      read(FID,*)dt
      read(FID,*)dtOut
    close(FID)

    t=0d0
    iOut=0
    tOutNext=dtOut
    nAvgOut=0

  end subroutine

  !> step particles
  subroutine stepPtcls()
    use modPush
    use modPICGrid
    use modPolyGrid
    use modGeometry
    integer::f,info
    double precision::h,a
    integer::n0(size(p))
    logical,allocatable::toBeRemoved(:)

    n0(:)=p(:)%n
    ! emission from particle sources
    do i=1,size(ptclSrc)
      call ptclSrc(i)%emit(p,grid,dt,nProc)
    end do
    ! push particles
    do j=1,size(p)
      allocate(toBeRemoved(p(j)%n))
      toBeRemoved(:)=.false.
      do i=1,p(j)%n
        h=dt
        if(i<=n0(j))then ! old particles
          call push(grid,p(j),i,h,phi,f,LF_NORMAL,info)
        else ! new particles
          call push(grid,p(j),i,h,phi,f,LF_REWIND,info)
        end if
        if(info==PUSH_IMPACT)then ! TODO add other particle BCs
          select case(grid%sE(f))
          case(TRI)
            a=a3p(grid%pN(:,grid%iNE(1:3,f)))
          case default
            a=0d0
          end select
          if(a>0d0)then
            wallHitDenLocal(f)=wallHitDenLocal(f)+p(j)%w(i)*p(j)%q/a
          end if
          toBeRemoved(i)=.true.
        end if
        if(info==PUSH_LOST)then
          write(*,*)'[W] PARTICLE LOST AT <x,y,z>:'
          write(*,*)p(j)%x(:,i)
          toBeRemoved(i)=.true.
        end if
      end do
      do i=p(j)%n,1,-1 ! reversed loop to ensure correct removal
        if(toBeRemoved(i))then
          call p(j)%rm(i)
        end if
      end do
      deallocate(toBeRemoved)
    end do

  end subroutine

  !> prepare data before writing the state (must run on all processes)
  subroutine preOut()
    use modMGS
    use modUglyFEM
    use mpi

    ! species density
    denLocal(:,:)=0d0
    do j=1,size(p)
      do i=1,p(j)%n
        call scatter(grid,p(j)%w(i),p(j)%iC(i),p(j)%xx(:,i),denLocal(:,j))
      end do
    end do
    forall(j=1:size(p))
      denLocal(:,j)=denLocal(:,j)/nVol(:)
    end forall
    call mpi_reduce(denLocal,den,size(den),MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD,ierr)

    ! electric field
    if(iProc==0)then
      call findNodalGrad(grid,phi,nVol,ef)
      ef(:,:)=-ef(:,:)
    end if

    ! wall hit current density
    call mpi_reduce(wallHitDenLocal,wallIDen,size(wallIDen),MPI_DOUBLE_PRECISION,MPI_SUM,0,&
    &               MPI_COMM_WORLD,ierr)
    if(nAvgOut>0)then
      wallIDen(:)=wallIDen(:)/dt/nAvgOut
    else
      wallIDen(:)=0d0
    end if
    wallHitDenLocal(:)=0d0
  end subroutine

  !> write the state to post-processing file
  subroutine writeState(fName)
    use modFileIO
    character(*),intent(in)::fName
    integer,parameter::FID=10
    character(20)::tmpStr
    double precision,allocatable::tmp1(:)

    if(.not.allocated(tmp1)) allocate(tmp1(grid%nE))

    open(FID,file=trim(fName),action='write')
    call writeVTK(FID,grid)
    call writeVTK(FID,grid,N_DATA)
    call writeVTK(FID,'phi',phi)
    call writeVTK(FID,'ef',ef)
    do i=1,size(p)
      write(tmpStr,*)i
      call writeVTK(FID,'den'//trim(adjustl(tmpStr)),den(:,i))
    end do
    call writeVTK(FID,grid,E_DATA)
    call writeVTK(FID,'geoID',dble(grid%gid))
    forall(i=1:grid%nE)
      tmp1(i)=merge(0d0,1d0,i<=grid%nC) ! 0 for cell, 1 for facet
    end forall
    call writeVTK(FID,'geoType',tmp1)
    call writeVTK(FID,'wallIDen',wallIDen)
    close(FID)
  end subroutine

  !> residual function of the FEM phi equation
  function phiRes(oldVector,newVector,dat)
    use iso_c_binding
    use ieee_arithmetic
    type(C_PTR),value::oldVector !< old N_Vector
    type(C_PTR),value::newVector !< new N_Vector
    type(C_PTR),value::dat !< optional user data object
    integer(C_INT)::phiRes !< error code
    double precision,pointer::x(:) !< fortran pointer associated with oldVector
    double precision,pointer::y(:) !< fortran pointer associated with newVector
    double precision,allocatable,save::tmp(:)

    call associateVector(oldVector,x)
    call associateVector(newVector,y)

    if(.not.allocated(tmp)) allocate(tmp(grid%nN))

    ! update rhsPhi to include electron model
    do i=1,grid%nN
      rhsPhi(i)=qDepo(i)-QE/EPS0*ne0BR*exp((x(i)-phi0BR)/kbTeBR)*nVol(i)
    end do
    rhsPhi=merge(rhsPhiDi,rhsPhi,isDirichlet)

    ! construct residual vector
    call negLaPhi%mulVec(x,y)
    y(1:grid%nN)=y(1:grid%nN)-rhsPhi(1:grid%nN)

    phiRes=merge(1,0,any(ieee_is_nan(y).or.(.not.ieee_is_finite(y))))
    if(c_associated(dat))then
    end if
  end function

  !> phi preconditioning matrix setup/factor
  function phiPSet(c_x,c_xScale,c_f,c_fScale,dat)
    use iso_c_binding
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,dat
    integer(C_INT)::phiPSet
    double precision,pointer::x(:),xScale(:),f(:),fScale(:)
    type(C_PTR)::foo
    double precision,parameter::DROPTOL=1e-6
    double precision,allocatable::dEm_dPhi(:) !< d (electron model term) / d phi

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)

    if(.not.allocated(dEm_dPhi)) allocate(dEm_dPhi(grid%nN))

    ! construct preconditioning matrix
    call phiLinEq%setCSR(negLaPhi%iA,negLaPhi%jA,negLaPhi%A)
    forall(i=1:grid%nN)
      dEm_dPhi(i)=merge(0d0,QE/EPS0*ne0BR/kbTeBR*exp((x(i)-phi0BR)/kbTeBR)*nVol(i),isDirichlet(i))
    end forall
    call phiLinEq%addDiag(dEm_dPhi)
    ! factorize preconditioning matrix
    call phiLinEq%fact(DROPTOL)

    phiPSet=0
    foo=dat
  end function

  !> phi preconditioning problem solving
  function phiPSol(c_x,c_xScale,c_f,c_fScale,c_v,dat)
    use iso_c_binding
    type(C_PTR),value::c_x,c_xScale,c_f,c_fScale,c_v,dat
    integer(C_INT)::phiPSol
    double precision,pointer::x(:),xScale(:),f(:),v(:),fScale(:)
    type(C_PTR)::foo
    double precision,allocatable,save::tmp1(:),tmp2(:)

    call associateVector(c_x,x)
    call associateVector(c_xScale,xScale)
    call associateVector(c_f,f)
    call associateVector(c_fScale,fScale)
    call associateVector(c_v,v)

    if(.not.allocated(tmp1)) allocate(tmp1(grid%nN))
    if(.not.allocated(tmp2)) allocate(tmp2(grid%nN))

    ! find x increment from f increment v and save back to v
    tmp1(1:grid%nN)=v(1:grid%nN)
    call phiLinEq%solve(tmp1,tmp2)
    v(1:grid%nN)=tmp2(1:grid%nN)

    phiPsol=0
    foo=dat
  end function

end module


C
       real*4 function ct_enh_inv_grey( rgb, ci, cimin, cimax )
C      --------------------------------------------------------
C
C Function defining an enhanced grey-scale.
C
C defining:
C             x = (cimax-ci)/(cimax-cimin)
C then:
C   ct_enh_inv_grey = ((x-lower_bound)/(upper_bound-lower_bound))**power
C
C for:
C  lower_bound  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_inv_grey = 0.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common.
*-

       include '../include/tv_modify.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x
       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         ct_enh_inv_grey = ((upper_bound-x)/(upper_bound-lower_bound))**
     *                 power_law
       else if (x.lt.lower_bound) then
         ct_enh_inv_grey = 1.0
       else
         ct_enh_inv_grey = 0.0
       end if
       end


      subroutine geig(g,h,d,p,s,t,id,nv)
c     implicit double precision (a-h,o-z)                                    dp
      dimension g(*),h(*),d(*),p(nv,1),s(nv,1),t(*),id(*)
      call jacobi (h,d,s,t,id,nv,ir)
      do 10 i=1,nv
      c=1./sqrt(d(i))
      id(i)=i*(i+1)/2
      do 10 j=1,nv
   10 s(j,i)=s(j,i)*c
      call pzero (p,nv*nv)
      do 20 i=1,nv
   20 call promul (g,s(1,i),p(1,i),id,nv)
      k=0
      do 30 j=1,nv
      do 30 i=1,j
      k=k+1
      h(k)=fdot(s(1,i),p(1,j),nv)
   30 continue
      call jacobi (h,d,p,t,id,nv,ir)
      call psorte (d,p,nv,.true.)
      do 60 j=1,nv
      do 40 i=1,nv
   40 t(i)=0.
      do 50 k=1,nv
      do 50 i=1,nv
   50 t(i)=t(i)+s(i,k)*p(k,j)
      do 60 i=1,nv
   60 p(i,j)=t(i)
      return
      end


C-----------------------------------------------------------------------
      SUBROUTINE SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPLEGEND    COMPUTE LEGENDRE POLYNOMIALS
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: EVALUATES THE ORTHONORMAL ASSOCIATED LEGENDRE POLYNOMIALS
C           IN THE SPECTRAL DOMAIN AT A GIVEN LATITUDE.
C           SUBPROGRAM SPLEGEND SHOULD BE CALLED ALREADY.
C           IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER,
C           AND EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) THEN
C           THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED:
C           PLN(0,0)=SQRT(0.5)
C           PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L))
C           PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N)
C           SYNTHESIS AT THE POLE NEEDS ONLY TWO ZONAL WAVENUMBERS.
C           SCALAR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 0 WHILE
C           VECTOR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 1.
C           (THUS POLAR VECTOR FIELDS ARE IMPLICITLY DIVIDED BY CLAT.)
C           THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED AT THE POLE:
C           PLN(0,0)=SQRT(0.5)
C           PLN(1,1)=SQRT(0.75)
C           PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N)
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C   98-06-10  MARK IREDELL  GENERALIZE PRECISION
C
C USAGE:    CALL SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     SLAT     - REAL SINE OF LATITUDE
C     CLAT     - REAL COSINE OF LATITUDE
C     EPS      - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1))
C     EPSTOP   - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP
C
C   OUTPUT ARGUMENT LIST:
C     PLN      - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL
C     PLNTOP   - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
CFPP$ NOCONCUR R
      REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1)
      REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
      REAL(KIND=SELECTED_REAL_KIND(15,45)):: DLN((M+1)*((I+1)*M+2)/2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  ITERATIVELY COMPUTE PLN WITHIN SPECTRAL DOMAIN AT POLE
      M1=M+1
      M2=2*M+I+1
      MX=(M+1)*((I+1)*M+2)/2
      IF(CLAT.EQ.0.) THEN
        DLN(1)=SQRT(0.5)
        IF(M.GT.0) THEN
          DLN(M1+1)=SQRT(0.75)
          DLN(2)=SLAT*DLN(1)/EPS(2)
        ENDIF
        IF(M.GT.1) THEN
          DLN(M1+2)=SLAT*DLN(M1+1)/EPS(M1+2)
          DLN(3)=(SLAT*DLN(2)-EPS(2)*DLN(1))/EPS(3)
          DO N=3,M
            K=1+N
            DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
            K=M1+N
            DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
          ENDDO
          IF(I.EQ.1) THEN
            K=M2
            DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
          ENDIF
          DO K=M2+1,MX
            DLN(K)=0.
          ENDDO
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN
        K=M1+1
        PLNTOP(1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(1)
        IF(M.GT.0) THEN
          K=M2+1
          PLNTOP(2)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(2)
          DO L=2,M
            PLNTOP(L+1)=0.
          ENDDO
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  ITERATIVELY COMPUTE PLN(L,L) (BOTTOM HYPOTENUSE OF DOMAIN)
      ELSE
        NML=0
        K=1
        DLN(K)=SQRT(0.5)
        DO L=1,M+(I-1)*NML
          KP=K
          K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
          DLN(K)=DLN(KP)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L))
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE PLN(L,L+1) (DIAGONAL NEXT TO BOTTOM HYPOTENUSE OF DOMAIN)
        NML=1
CDIR$ IVDEP
        DO L=0,M+(I-1)*NML
          K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
          DLN(K)=SLAT*DLN(K-1)/EPS(K)
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE REMAINING PLN IN SPECTRAL DOMAIN
        DO NML=2,M
CDIR$ IVDEP
          DO L=0,M+(I-1)*NML
            K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
            DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K)
          ENDDO
        ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN
        DO L=0,M
          NML=M+1+(I-1)*L
          K=L*(2*M+(I-1)*(L-1))/2+L+NML+1
          PLNTOP(L+1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(L+1)
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  RETURN VALUES
      DO K=1,MX
        PLN(K)=DLN(K)
      ENDDO
      RETURN
      END


module cliffs_tolkova_mod
    !!
    !!
    !! This module contains edited excerpts from the Cliffs solver. Cliffs was developed by
    !! Elena Tolkova. It is based on the MOST solver but has an alternate treatment of
    !! wetting and drying.
    !!
    !! The Cliffs code is available on github (https://github.com/Delta-function/cliffs-src)
    !! under a FreeBSD licence. The code here is a modified version of that.
    !!
    !! Below we reproduce the copyright information of cliffs_main.f as required by the FreeBSD licence.
    !!
    !!

    !!! From cliffs_main.f !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !! https://github.com/Delta-function/cliffs-src/blob/master/cliffs_main.f
    !!
    !!  Cliffs is an open-source model for tsunami propagation and inundation computations
    !!  in the framework of the shallow-water equations. Cliffs implements:
    !!  (1) VTCS-2 finite-difference scheme in an open ocean and on the open boundary
    !! 	 as in (Titov and Synolakis, 1995, 1998);
    !!  (2) dimensional splitting as in (Titov and Gonzalez, 1997; Titov and Synolakis, 1998);
    !!  (3) reflection and inundation computations as in (Tolkova, 2014);
    !!  (4) data flows similar to curvilinear MOST and MOST-4 (Burwell and Tolkova, 2008).
    !!                               REFERENCE:
    !!  E. Tolkova. Land-Water Boundary Treatment for a Tsunami Model With Dimensional Splitting
    !!  Pure and Applied Geophysics, Vol. 171, Issue 9 (2014), pp. 2289-2314
    !!
    !!  FEATURES: Cartezian or Geophysical (lon/lat) coordinates; 2D or 1D domains;
    !!           grid nesting with one-way coupling; initial conditions or/and boundary forcing;
    !!           Open MP; NetCDF format of I/O
    !!
    !!           Copyright (c) 2014, Elena Tolkova
    !!           under the terms of FreeBSD License
    !!
    !!  Redistribution and use in source and binary forms, with or without
    !!  modification, are permitted provided that the following conditions are met:
    !!
    !!   1. Redistributions of source code must retain the above copyright notice, this
    !!     list of conditions and the following disclaimer.
    !!   2. Redistributions in binary form must reproduce the above copyright notice,
    !!     this list of conditions and the following disclaimer in the documentation
    !!     and/or other materials provided with the distribution.
    !!
    !!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
    !!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
    !!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
    !!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
    !!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
    !!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    !!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
    !!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
    !!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    !!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    !!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !! From cliffs.f !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !! https://github.com/Delta-function/cliffs-src/blob/master/cliffs.f
    !!
    !! Cliffs SOLVER to propagate tsunami wave through one time step in 1D with:                !
    !! (1) VTCS-2 finite-difference scheme in an open ocean and on the open boundary            !
    !!	 as in (Titov and Synolakis, 1995, 1998)                                             !
    !! (2) reflection and inundation computations as in (Tolkova, 2014)                         !
    !!                               REFERENCES:                                                !
    !! V. Titov and C. Synolakis. Modeling of Breaking and Nonbreaking Long-Wave Evolution and  !
    !! Runup Using VTCS-2. J. of Waterway, Port, Coastal, and Ocean Eng. Vol. 121, No 6 (1995), !
    !! pp. 308-316.                                                                             !
    !! E. Tolkova. Land-Water Boundary Treatment for a Tsunami Model With Dimensional Splitting.!
    !! Pure and Applied Geophysics, Vol. 171, Issue 9 (2014), pp. 2289-2314                     !
    !!                                                                                !
    !!     Copyright (C) 2014, Elena Tolkova                                                    !
    !!     For conditions of distribution and use, see copyright notice in cliffs_main.f        !
    !!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! SWALS parameters
    use global_mod, only : dp, ip, gravity
    use logging_mod, only: log_output_unit

    implicit none

    ! Parameters required by Cliffs
    real(dp), parameter :: grav = gravity, sqr2 = sqrt(2.0_dp)

    contains

    subroutine cliffs(dt, iu, irw, n, cliffs_minimum_allowed_depth, &
                      elev, cel, xvel, yvel, s1, s2, zeta, manning_squared, &
                      linear_friction_coeff)
        !! This is the Cliffs 1D time-stepping routine.
        !! It was originally taken from the cliffs source-code by Elena Tolkova, see comments above for licence etc.
        !! Compared with the cliffs original version, the code below has various interface edits to cleanly integrate into SWALS.

        ! GD comment -- arguments are:
        !    dt -- timestep
        !    iu -- integer, has values 1 or 2 -- referring to computations in x(lon) or y(lat) slice
        !    irw -- the y or x index of the grid that this slice represents
        !    n -- the number of x or y values in this slice.
        !    cliffs_minimum_allowed_depth -- the 'ground' parameter in cliffs, which is a wet/dry depth threshold.
        !                                    This value needs to be tuned for the problem.
        ! GD Comments
        !
        ! elev(nXn,nYn) -- used in place of 'dep' in cliffs.f, which is the "undisturbed water depth" or "depth below MSL" --
        !                  same as my "-domain%U(,,ELV)". So below the original cliffs routine is modified to
        !                  use '-elev' instead of 'dep'
        ! cel(nXn,nYn) -- sqrt(g * real_water_depth). Note the code sometimes uses 'h' to represent this
        ! xvel(nXn,nYn) -- x velocity
        ! yvel(nXn,nYn) -- y velocity
        ! s1 -- x-direction cell size -- for SWALS, I reduced it to a constant (for each slice)
        ! s2 -- y-direction cell size -- for SWALS I reduced it to a constant (for each slice)
        ! zeta(nYn) -- spherical coordinate scale factor. In CLIFFS this is 0.125/Earth_Radius * tan(pi/180 * lat)
        ! manning_squared -- like 'crough' in the original cliffs.f source -- except for the version below, by default we use
        !                    the standard manning formula (despite the expensive power-law computation)
        ! linear_friction_coeff -- drag term, which if written in terms of the depth-integrated-velocity equations, would be
        !                          like subtracting "linear_friction_coef * UH (or VH)" from the right-hand-side of the UH/VH
        !                          evolution equations. This form of drag is used in Fine et al (2012) and Kulikov et al (2014)
        real(dp), intent(in):: dt, cliffs_minimum_allowed_depth
        integer(ip), intent(in) :: iu,irw,n
        real(dp), intent(in) :: elev(:,:), s1, s2, zeta(:), manning_squared(:,:) !, edge1(:,:), edge2(:,:)
        real(dp), intent(inout) :: cel(:,:), xvel(:,:), yvel(:,:)
        real(dp), intent(in) :: linear_friction_coeff

        real(dp) :: h(n),pp(n),qq(n),vv(n),dx(n),scl(n)
        real(dp) :: depth(n),Pinv(n),Qinv(n),v(n),u(n), crough(n)
        real(dp) :: pqvdL(4,99), pqvdR(4,99)
        real(dp) :: uj,vj,pj,qj,dpj,dpm,dtx,hj
        real(dp) :: ej,e2,e1,Qpm,Qpj,Qjm,Qsum
        real(dp) :: v1,v2,d1,d2,p1,p2,q1,q2
        real(dp) :: cc,sphr,fm,fp,flood
        integer(ip) :: i,j,i1,i2,kseg,k,k1,k2
        integer(ip) :: lghost(n),rghost(n)
        logical :: land(n),water,newland(n)
        real(dp) :: ground, celmin

        ! Cliffs parameters
        ground = cliffs_minimum_allowed_depth
        celmin = sqrt(gravity * cliffs_minimum_allowed_depth)

        ! GD -- This is packing a 1D slice of the 2D grid into a 1D array (the algorithm is based on dimension splitting, so is
        !       essentially 1D)
        if(iu.eq.1) then
            ! GD -- iu == 1, Computations in lon (x) direction
             do i = 1,n
                depth(i)= -elev(i,irw) ! GD Comment -- here we use negative elevation in place of 'dep' in CLIFFS
                h(i) = cel(i,irw)
                u(i) = xvel(i,irw)
                v(i) = yvel(i,irw)
                dx(i) = s1
                scl(i) = 0
                crough(i) = manning_squared(i, irw)
            end do
        else
            ! GD -- iu == 2, Computations in lat (y) direction
            do i = 1,n
                depth(i)= -elev(irw,i) ! GD Comment -- here we use negative elevation in place of 'dep' in CLIFFS
                h(i) = cel(irw,i)
                u(i) = yvel(irw,i)
                v(i) = xvel(irw,i)
                dx(i) = s2
                scl(i) = zeta(i)
                crough(i) = manning_squared(irw, i)
           end do
        endif

        !
        ! GD -- note below here, everything is 1D, until the very end where arrays are repacked.
        !

        lghost(1:n)=0
        rghost(1:n)=0
        ! Find dry areas
        land=.false.
        do j=1,n
            if(h(j).le.celmin) land(j)=.true.
        end do
        newland=land

        ! GD -- figure out if the left-most-cell is land or water
        water=.false.
        kseg=0
        if(.not.land(1)) then
            water=.true.
            kseg=1
            lghost(1)=1
        endif
        k1=kseg+1 ! first segment with left shore

        ! GD -- some wetting and drying stuff
        do i= 2,n
            if(water) then
                ! Here segment (i-1) is wet
                if(land(i)) then
                    ! Here segment (i) is dry

                    ! GD Comment -- notice h**2 / grav = (grav * real_water_depth / grav ) = real_water_depth.
                    !               Whereas 'depth' here refers to the "undisturbed water depth"
                    !               So "(h(i-1)**2)/grav-depth(i-1)" is like stage(i-1),
                    !               flood = stage(i-1) + undisturbed_water_depth(i)
                    flood=(h(i-1)**2)/grav-depth(i-1)+depth(i)
                    if((flood.gt.ground).and.(.not.land(i-1)).and.(u(i-1).gt.0)) then ! expand
                        ! GD Comment -- here, the dry cell has u/v/depth extrapolated from its left neighbour,
                        !               because 'flood' was deep enough to suggest flooding occurs
                        u(i)=u(i-1)
                        v(i)=v(i-1)
                        h(i)=celmin
                        newland(i)=.false.
                    else
                        ! GD Comment -- here, segment (i) remains dry
                        water=.false. ! close wet segment
                        rghost(kseg)=i
                    endif
                endif
            else
                ! Here segment(i-1) is dry
                if(.not.land(i)) then ! start wet segment
                    ! Here segment (i) is wet
                    water = .true.
                    kseg = kseg+1
                    ! GD Comment -- so 'flood' = stage(i) + undisturbed_water_depth(i-1)
                    !               See comment above for details
                    flood = (h(i)**2)/grav-depth(i)+depth(i-1)
                    if((flood.gt.ground).and.(u(i).lt.0)) then ! expand
                        !! Here the initially dry 'i-1' cell has u/v/depth extrapolated because it
                        !! seems flooding should occur, based on 'flood'
                        lghost(kseg)=max(i-2,1)
                        newland(i-1)=.false.
                        u(i-1)=u(i)
                        v(i-1)=v(i)
                        h(i-1)=celmin
                    else
                        !! Here segment (i-1) remains dry
                        lghost(kseg)=i-1
                    end if

                    if(kseg.gt.1) then
                        if((lghost(kseg).lt.rghost(kseg-1))) then ! glue to previous wet segment
                            lghost(kseg)=0
                            kseg=kseg-1
                            rghost(kseg)=0
                        end if
                    end if
                endif
            endif
        end do

        if(kseg.eq.0) return !goto 99
        if (rghost(kseg).eq.0) rghost(kseg)=n
        k2=kseg-1
        if(newland(rghost(kseg))) k2=kseg

        where(newland)
            h=0
            u=0
            v=0
        end where
        vv=v

        !   compute Riemann invarients
        Pinv=0
        Qinv=0
        !   - in open sea
        do k=1,kseg
            i1=lghost(k)+1
            i2=rghost(k)-1
            do i = i1,i2
                Pinv(i)=u(i)+2*h(i)
                Qinv(i)=u(i)-2*h(i)
            end do
        enddo
        !    - on left shoreline in ghost node
        if (k1.le.kseg) then
            do k=k1,kseg
                i=lghost(k)
                j=i+1
                pqvdL(1:4,k)=(/-Qinv(j), -Pinv(j), v(j), depth(j)/)
            enddo
        endif
        !    - on right shoreline in ghost node
        if (k2.ge.1) then
            do k=1,k2
                i=rghost(k)
                j=i-1
                pqvdR(1:4,k)=(/-Qinv(j), -Pinv(j), v(j), depth(j)/)
            end do
        endif
        !    - on left wet edge
        if(.not.newland(1)) then
            Pinv(1)=u(1)+2*h(1)
            Qinv(1)=u(1)-2*h(1)
            pqvdL(1:4,1)=(/Pinv(1), Qinv(1), v(1), depth(1)/)
        end if
        !    - on right wet edge
        if(.not.newland(n)) then
            Pinv(n)=u(n)+2*h(n)
            Qinv(n)=u(n)-2*h(n)
            pqvdR(1:4,kseg)=(/Pinv(n), Qinv(n), v(n), depth(n)/)
        end if
        qq=Qinv
        pp=Pinv

        ! time-step integration
        do k=1,kseg

            i1=lghost(k)+1
            i2=rghost(k)-1
            if(i1.gt.i2) cycle !goto 9

            do i=i1,i2

                j=i-1
                if(i==i1) then
                    p1=pqvdL(1,k)
                    q1=pqvdL(2,k)
                    v1=pqvdL(3,k)
                    d1=pqvdL(4,k)
                else
                    p1=Pinv(j)
                    q1=Qinv(j)
                    v1=v(j)
                    d1=depth(j)
                end if
                j=i+1;
                if(i==i2) then
                    p2=pqvdR(1,k)
                    q2=pqvdR(2,k)
                    v2=pqvdR(3,k)
                    d2=pqvdR(4,k)
                else
                    p2=Pinv(j)
                    q2=Qinv(j)
                    v2=v(j)
                    d2=depth(j)
                end if
                uj=u(i)
                vj=v(i)
                ! GD Comment -- hj = real_water_depth(i)
                hj=h(i)**2/grav
                !  Almost Manning - Preferred friction model
                !cc=grav*crough(i)*uj*sqrt((uj**2+vj**2)/hj)/hj
                !   Drag force
                !  		cc=grav*crough(i)*uj*sqrt(uj**2+vj**2)/hj
                !  Manning friction - SLOW -- but for SWALS we use this by default
                cc = grav*crough(i)*uj*sqrt(uj**2+vj**2)/hj**(4.0_dp/3.0_dp) + &
                    ! Here we append a linear drag model like Fine et al., (2012), Kulikov et al., (2014).
                    linear_friction_coeff * uj

                pj=Pinv(i)
                qj=Qinv(i)
                sphr=(pj-qj)*(pj+qj)*scl(i)

                dpj=grav*(d2-depth(i))
                dpm=grav*(d2-d1)
                fm=dx(i-1)
                fp=dx(i)
                dtx=dt/(fm+fp)

                ej=3*pj+qj
                e2=3*p2+q2
                e1=3*p1+q1
                Qpm=0.125*(e2+e1)*(p2-p1)-dpm
                Qpj=0.125*(e2+ej)*(p2-pj)-dpj
                Qjm=0.125*(ej+e1)*(pj-p1)-dpm+dpj
                Qsum=Qpm+0.25*ej*dt*(Qjm/fm-Qpj/fp)
                pp(i)=pj-dtx*Qsum-dt*(cc-sphr)

                ej=3*qj+pj
                e2=3*q2+p2
                e1=3*q1+p1
                Qpm=0.125*(e2+e1)*(q2-q1)-dpm
                Qpj=0.125*(e2+ej)*(q2-qj)-dpj
                Qjm=0.125*(ej+e1)*(qj-q1)-dpm+dpj
                Qsum=Qpm+0.25*ej*dt*(Qjm/fm-Qpj/fp)
                qq(i)=qj-dtx*Qsum-dt*(cc+sphr)

                Qsum=(v2-vj)/fp-(vj-v1)/fm
                vv(i)=vj-uj*dtx*(v2-v1-Qsum*(uj*dt+fp-fm))
            end do
        end do

        do k=1,kseg
            i1=lghost(k)+1
            i2=rghost(k)-1
            do i=i1,i2
                h(i)=(pp(i)-qq(i))/4
                u(i)=(pp(i)+qq(i))/2
            end do
        end do

        !   check water surface angle on left shoreline
        if (k1.le.kseg) then
            do k=k1,kseg
                i=lghost(k)+1
                j=i+1
                if(land(i)) then ! if newly included node
                    if(sqr2*h(i).gt.h(j)) then
                        h(i)=h(j)/sqr2
                        u(i)=u(j)/2
                        vv(i)=vv(j)/2
                    endif
                endif
            enddo
        endif
        !   check water surface angle on right shoreline
        if (k2.ge.1) then
            do k=1,k2
                i=rghost(k)-1
                j=i-1
                if(land(i)) then ! if newly included node
                    if(sqr2*h(i).gt.h(j)) then
                        h(i)=h(j)/sqr2
                        u(i)=u(j)/2
                        vv(i)=vv(j)/2
                    endif
                endif
            enddo
        endif

        !! For SWALS we can skip these boundary conditions, and rely on the regular boundary treatment.
        !!
        !! Integration in edges
        !flood=edge1(irw,3)+depth(1)
        !if((.not.newland(1)).and.(.not.newland(2)) .and.(flood.gt.ground)) then
        !    pj=Pinv(1)
        !    qj=Qinv(1)
        !    p2=Pinv(2)
        !    q2=Qinv(2)
        !    sphr=(pj-qj)*(pj+qj)*scl(1)
        !    Qpj=(3*(q2+qj)+p2+pj)*(q2-qj)/8-grav*(depth(2)-depth(1))
        !    qq(1)=qj-dt*(Qpj/dx(1)+sphr)
        !    pp(1)=edge1(irw,iu)+2*sqrt(grav*flood)
        !    if(u(1).lt.0) then
        !        vv(1)=v(1)-dt*(v(2)-v(1))*u(1)/dx(1)
        !    else
        !        vv(1)=edge1(irw,3-iu)
        !    end if
        !    h(1)=(pp(1)-qq(1))/4
        !    u(1)=(pp(1)+qq(1))/2
        !endif
        !flood=depth(n)+edge2(irw,3)
        !if((.not.newland(n-1)).and.(.not.newland(n)) .and.(flood.gt.ground)) then
        !    pj=Pinv(n)
        !    qj=Qinv(n)
        !    p1=Pinv(n-1)
        !    q1=Qinv(n-1)
        !    sphr=(pj-qj)*(pj+qj)*scl(n)
        !    Qjm=(3*(p1+pj)+q1+qj)*(pj-p1)/8-grav*(depth(n)-depth(n-1))
        !    pp(n)=pj-dt*(Qjm/dx(n-1)-sphr)
        !    qq(n)=edge2(irw,iu)-2*sqrt(grav*flood)

        !    if(u(n).gt.0) then
        !       vv(n)=v(n)-dt*(v(n)-v(n-1))*u(n)/dx(n-1)
        !    else
        !       vv(n)=edge2(irw,3-iu)
        !    end if
        !    h(n)=(pp(n)-qq(n))/4
        !    u(n)=(pp(n)+qq(n))/2
        !endif

        !
        ! GD comment -- here the arrays are re-packed.
        !

        if(iu.eq.1_ip) then
            do i = 1,n
                cel(i,irw)=h(i)
                xvel(i,irw)=u(i)
                yvel(i,irw)=vv(i)
            end do
        else
            do i=1,n
               cel(irw,i)=h(i)
               xvel(irw,i)=vv(i)
               yvel(irw,i)=u(i)
            end do
        endif

        ! 99  	continue
    end subroutine cliffs

    subroutine setSSLim(nXn,nYn,bbb,alpha,depmin)
        !! The Cliffs bathymetry smoother.
        !! This bathymetry smoothing routine is from the CLIFFS source code by Elena Tolkova. It also has superficial edits to cleanly
        !! integrate into SWALS. See comments at the top of this file for licence information etc.
        !! Cliffs tends to go unstable if the bathymetry is insufficiently smooth (see analysis by Tolkova in the CLIFFS manual), so
        !! this routine is very important.

        integer(ip), intent(in) :: nXn,nYn
        real(dp), intent(inout) :: bbb(nXn,nYn)
        real(dp), intent(in) :: alpha,depmin

        real(dp) :: c1,c2,alp2,dep
        real(dp), dimension(:), allocatable :: q,p
        logical, dimension(:), allocatable :: land
        integer(ip) nodes,n,i,j,itry,nm

        nm=max(nXn,nYn)
        allocate(q(nm),p(nm))
        allocate(land(nm))

        write(log_output_unit,*) 'Applying CLIFFS bathymetry smoother with alpha=', alpha
        write(log_output_unit,*) '    Node-wise depth adjustments in open water:'
        ! Repeat the smoother a fixed number of times
        do itry=1,12

            nodes=0
            ! Smooth in y direction
            do i=1,nXn
                q(1:nYn)=bbb(i,1:nYn)
                p(1:nYn)=q(1:nYn)
                land(1:nm)=.false.
                do j=1,nYn
                    if (q(j).lt.depmin) then
                        land(j)=.true.
                    else
                        q(j)=sqrt(q(j))
                    endif
                enddo
                n=nYn-1
                do j=2,n
                    if(.not.(land(j-1).or.land(j).or.land(j+1))) then
                        c1=q(j+1)/q(j)
                        c2=q(j-1)/q(j)
                        if ((c1.gt.alpha).or.(c2.gt.alpha)) then
                            q(j)=(q(j-1)+q(j+1))/2
                            p(j)=q(j)*q(j)
                            nodes=nodes+1
                        endif
                    endif
                enddo
                bbb(i,1:nYn)=p(1:nYn)
            enddo

            ! Smooth in x direction
            do i=1,nYn
                q(1:nXn)=bbb(1:nXn,i)
                p(1:nXn)=q(1:nXn)
                land(1:nm)=.false.
                do j=1,nXn
                    if (q(j).lt.depmin) then
                        land(j)=.true.
                    else
                        q(j)=sqrt(q(j))
                    endif
                enddo
                n=nXn-1
                do j=2,n
                    if(.not.(land(j-1).or.land(j).or.land(j+1))) then
                        c1=q(j+1)/q(j)
                        c2=q(j-1)/q(j)
                        if ((c1.gt.alpha).or.(c2.gt.alpha)) then
                            q(j)=(q(j-1)+q(j+1))/2
                            p(j)=q(j)*q(j)
                            nodes=nodes+1
                        endif
                    endif
                enddo
                bbb(1:nXn,i)=p(1:nXn)
            enddo
            write(log_output_unit,*) '    passage',itry,':',nodes,' nodes adjusted'
            if(nodes.eq.0) exit

        enddo  ! end itry loop

        if(nodes.ne.0) write(log_output_unit,*) '    ATTN: processing is not complete - too rough bathy or too small alpha'

        !
        ! A second-type of smoothing below here
        !

        write(log_output_unit,*) '    Adjustments at coastlines:'
        alp2=alpha**2
        do itry=1,12

            nodes=0
            ! Along y direction
            do i=1,nXn
                q(1:nYn)=bbb(i,1:nYn)
                land(1:nm)=.false.
                do j=1,nYn
                    if (q(j).lt.depmin) land(j)=.true.
                enddo
                n=nYn-1
                do j=2,n
                    if(.not.land(j)) then
                        if(land(j+1).and.(.not.land(j-1)) .or. (.not.land(j+1)).and.land(j-1)) then
                            if(land(j+1)) then
                                dep=q(j-1)
                            else
                                dep=q(j+1)
                            endif
                            if( dep/q(j).gt.alp2 ) then
                                q(j)=dep/alp2
                                nodes=nodes+1
                            endif
                        endif
                    endif
                enddo
                bbb(i,1:nYn)=q(1:nYn)
            enddo

            ! Along x direction
            do i=1,nYn
                q(1:nXn)=bbb(1:nXn,i)
                land(1:nm)=.false.
                do j=1,nXn
                    if (q(j).lt.depmin) land(j)=.true.
                enddo
                n=nXn-1
                do j=2,n
                    if(.not.land(j)) then
                        if(land(j+1).and.(.not.land(j-1)) .or.(.not.land(j+1)).and.land(j-1)) then
                            if(land(j+1)) then
                                dep=q(j-1)
                            else
                                dep=q(j+1)
                            endif
                            if( dep/q(j).gt.alp2 ) then
                                q(j)=dep/alp2
                                nodes=nodes+1
                            endif
                        endif
                    endif
                enddo
                bbb(1:nXn,i)=q(1:nXn)
            enddo
            write(log_output_unit,*) '    passage',itry,':',nodes,' nodes adjusted'

            if(nodes.eq.0) exit
        enddo  ! end itry loop

        if(nodes.ne.0) write(log_output_unit,*) '    ATTN: processing is not complete - too rough bathy or too small alpha'

    end subroutine setSSLim

end module


module module_cam_gffgch
  implicit none
  private
  public gffgch
contains
subroutine gffgch(t ,es ,itype )
   use shr_kind_mod, only: r8 => shr_kind_r8
   use physconst, only: tmelt
   use module_cam_support, only: endrun, &
                                 iulog
   implicit none
   real(r8), intent(in) :: t
   integer, intent(inout) :: itype
   real(r8), intent(out) :: es
   real(r8) e1
   real(r8) e2
   real(r8) eswtr
   real(r8) f
   real(r8) f1
   real(r8) f2
   real(r8) f3
   real(r8) f4
   real(r8) f5
   real(r8) ps
   real(r8) t0
   real(r8) term1
   real(r8) term2
   real(r8) term3
   real(r8) tr
   real(r8) ts
   real(r8) weight
   integer itypo
   if (itype < 0) then
      tr = abs(real(itype,r8))
      itypo = itype
      itype = 1
   else
      tr = 0.0_r8
      itypo = itype
   end if
   if (tr > 40.0_r8) then
      write(iulog,900) tr
      call wrf_message(iulog)
      call endrun ('GFFGCH')
   end if
   if(t < (tmelt - tr) .and. itype == 1) go to 10
   ps = 1013.246_r8
   ts = 373.16_r8
   e1 = 11.344_r8*(1.0_r8 - t/ts)
   e2 = -3.49149_r8*(ts/t - 1.0_r8)
   f1 = -7.90298_r8*(ts/t - 1.0_r8)
   f2 = 5.02808_r8*log10(ts/t)
   f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8
   f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8
   f5 = log10(ps)
   f = f1 + f2 + f3 + f4 + f5
   es = (10.0_r8**f)*100.0_r8
   eswtr = es
   if(t >= tmelt .or. itype == 0) go to 20
10 continue
   t0 = tmelt
   term1 = 2.01889049_r8/(t0/t)
   term2 = 3.56654_r8*log(t0/t)
   term3 = 20.947031_r8*(t0/t)
   es = 575.185606e10_r8*exp(-(term1 + term2 + term3))
   if (t < (tmelt - tr)) go to 20
   weight = min((tmelt - t)/tr,1.0_r8)
   es = weight*es + (1.0_r8 - weight)*eswtr
20 continue
   itype = itypo
   return
900 format('GFFGCH: FATAL ERROR ******************************',/, &
           'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', &
           ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', &
           ' 40.0 DEGREES C',/, ' TR = ',f7.2)
end subroutine gffgch
end module module_cam_gffgch


*DECK BESK0E
      FUNCTION BESK0E (X)
C***BEGIN PROLOGUE  BESK0E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0E-S, DBSK0E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0E(X) computes the exponentially scaled modified (hyperbolic)
C Bessel function of third kind of order zero for real argument
C X .GT. 0.0, i.e., EXP(X)*K0(X).
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C Series for AK0        on the interval  1.25000D-01 to  5.00000D-01
C                                        with weighted error   5.34E-17
C                                         log weighted error  16.27
C                               significant figures required  14.92
C                                    decimal places required  16.89
C
C Series for AK02       on the interval  0.          to  1.25000D-01
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  14.67
C                                    decimal places required  17.20
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK0E
      DIMENSION BK0CS(11), AK0CS(17), AK02CS(14)
      LOGICAL FIRST
      SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA AK0CS( 1) /   -.0764394790 3327941E0 /
      DATA AK0CS( 2) /   -.0223565260 5699819E0 /
      DATA AK0CS( 3) /    .0007734181 1546938E0 /
      DATA AK0CS( 4) /   -.0000428100 6688886E0 /
      DATA AK0CS( 5) /    .0000030817 0017386E0 /
      DATA AK0CS( 6) /   -.0000002639 3672220E0 /
      DATA AK0CS( 7) /    .0000000256 3713036E0 /
      DATA AK0CS( 8) /   -.0000000027 4270554E0 /
      DATA AK0CS( 9) /    .0000000003 1694296E0 /
      DATA AK0CS(10) /   -.0000000000 3902353E0 /
      DATA AK0CS(11) /    .0000000000 0506804E0 /
      DATA AK0CS(12) /   -.0000000000 0068895E0 /
      DATA AK0CS(13) /    .0000000000 0009744E0 /
      DATA AK0CS(14) /   -.0000000000 0001427E0 /
      DATA AK0CS(15) /    .0000000000 0000215E0 /
      DATA AK0CS(16) /   -.0000000000 0000033E0 /
      DATA AK0CS(17) /    .0000000000 0000005E0 /
      DATA AK02CS( 1) /   -.0120186982 6307592E0 /
      DATA AK02CS( 2) /   -.0091748526 9102569E0 /
      DATA AK02CS( 3) /    .0001444550 9317750E0 /
      DATA AK02CS( 4) /   -.0000040136 1417543E0 /
      DATA AK02CS( 5) /    .0000001567 8318108E0 /
      DATA AK02CS( 6) /   -.0000000077 7011043E0 /
      DATA AK02CS( 7) /    .0000000004 6111825E0 /
      DATA AK02CS( 8) /   -.0000000000 3158592E0 /
      DATA AK02CS( 9) /    .0000000000 0243501E0 /
      DATA AK02CS(10) /   -.0000000000 0020743E0 /
      DATA AK02CS(11) /    .0000000000 0001925E0 /
      DATA AK02CS(12) /   -.0000000000 0000192E0 /
      DATA AK02CS(13) /    .0000000000 0000020E0 /
      DATA AK02CS(14) /   -.0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0E
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3))
         NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0E',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X)
     1  - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) )
      RETURN
C
 20   IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0))
     1  / SQRT(X)
      IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02))
     1  / SQRT(X)
C
      RETURN
      END