!
!     "dftmod" computes the modulus of the discrete Fourier transform
!     of "bsarray" and stores it in "bsmod"
!
!
subroutine dftmod (bsmod,bsarray,nfft,order)
implicit none
integer::i,j,k
integer::nfft,jcut
integer::order,order2
real(kind=8)::eps,zeta
real(kind=8)::arg,factor
real(kind=8)::sum1,sum2
real(kind=8)::bsmod(*)
real(kind=8)::bsarray(*)
real(kind=8)::pi
pi=3.1415926535897932384626433832795029d0
!
!     get the modulus of the discrete Fourier transform
!
factor = 2.0d0 * pi / dble(nfft)
do i = 1, nfft
   sum1 = 0.0d0
   sum2 = 0.0d0
   do j = 1, nfft
      arg = factor * dble((i-1)*(j-1))
      sum1 = sum1 + bsarray(j)*cos(arg)
      sum2 = sum2 + bsarray(j)*sin(arg)
   end do
   bsmod(i) = sum1**2 + sum2**2
end do
!
!     fix for exponential Euler spline interpolation failure
!
eps = 1.0d-7
if (bsmod(1) .lt. eps)  bsmod(1) = 0.5d0 * bsmod(2)
do i = 2, nfft-1
   if (bsmod(i) .lt. eps)  &
        &   bsmod(i) = 0.5d0 * (bsmod(i-1)+bsmod(i+1))
end do
if (bsmod(nfft) .lt. eps)  bsmod(nfft) = 0.5d0 * bsmod(nfft-1)
!
!     compute and apply the optimal zeta coefficient
!
jcut = 50
order2 = 2 * order
do i = 1, nfft
   k = i - 1
   if (i .gt. nfft/2)  k = k - nfft
   if (k .eq. 0) then
      zeta = 1.0d0
   else
      sum1 = 1.0d0
      sum2 = 1.0d0
      factor = pi * dble(k) / dble(nfft)
      do j = 1, jcut
         arg = factor / (factor+pi*dble(j))
         sum1 = sum1 + arg**order
         sum2 = sum2 + arg**order2
      end do
      do j = 1, jcut
         arg = factor / (factor-pi*dble(j))
         sum1 = sum1 + arg**order
         sum2 = sum2 + arg**order2
      end do
      zeta = sum2 / sum1
   end if
   bsmod(i) = bsmod(i) * zeta**2
end do

return
end subroutine dftmod


PROGRAM LU
  ! This program demonstrates LU factorization (actually just Gaussian
  ! Elimination) by solving the following equation system:
  !
  ! |  2  1 -1 |     |   8 |
  ! | -3 -1  2 | X = | -11 |
  ! | -2  1  2 |     |  -3 |
  !
  ! The solution to this equation is:
  !
  !     |  2 |
  ! X = |  3 |
  !     | -1 |

  IMPLICIT NONE
  INCLUDE 'mpif.h'

  ! Configuration variables
  INTEGER, PARAMETER   :: n = 3
  REAL, DIMENSION(n,n) :: a = &
        RESHAPE ( (/ 2, -3, -2, 1, -1, 1, -1, 2, 2 /), (/3,3/) )
  REAl, DIMENSION(n)   :: b = (/ 8, -11, -3 /)

  ! MPI variables
  INTEGER               :: nprocs
  INTEGER               :: myrank
  INTEGER               :: ierr
  INTEGER, DIMENSION(n) :: map       ! column to process

  ! Count and temporary variables
  INTEGER :: i, ii, j, k, offset
  REAL    :: s, ss

  ! Initialize MPI
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr)

  ! Assign the column in a to the processes in a cylic manner
  DO i = 0, n
    map(i+1) = MOD(i, nprocs)
  ENDDO

  ! LU factorization
  DO k = 1, n
    IF (map(k) == myrank) THEN
      DO i = k+1, n
        a(i,k) = a(i,k) / a(k,k)
      ENDDO
    ENDIF
    CALL MPI_BCAST(a(k,k), n-k+1, MPI_REAL, map(k), MPI_COMM_WORLD, ierr)
    DO j = k+1, n
      IF (map(j) == myrank) THEN
        DO i = k+1, n
          a(i,j) = a(i,j) - a(i,k) * a(k,j)
        ENDDO
      ENDIF
    ENDDO
  ENDDO

  ! Forward elimination
  DO i = 2, n
    s = 0.0
    ! Process 0 owns column 1, process 1 owns column 2, etc.
    DO j = 1 + myrank, i - 1, nprocs
      s = s + a(i,j) * b(j)
    ENDDO
    CALL MPI_ALLREDUCE(s, ss, 1, MPI_REAL, MPI_SUM, MPI_COMM_WORLD, ierr)
    b(i) = b(i) - ss
  ENDDO

  ! Backward substitution
  DO i = n, 1, -1
    ! Starting from column i+1, find the first column that this process owns
    offset = myrank - map(i+1)
    IF (offset < 0) THEN
      offset = offset + nprocs
    ENDIF
    ii = i + 1 + offset

    s = 0.0
    DO j = ii, n, nprocs
      s = s + a(i, j) * b(j)
    ENDDO
    CALL MPI_ALLREDUCE(s, ss, 1, MPI_REAL, MPI_SUM, MPI_COMM_WORLD, ierr)
    b(i) = (b(i) - ss) / a(i,i)
  ENDDO

  IF (myrank == 0) write (*,*) "x = (", b, ")"

  CALL MPI_Finalize(ierr)
END PROGRAM LU


subroutine sieve(is_prime, n_max)
! =====================================================
! Uses the sieve of Eratosthenes to compute a logical
! array of size n_max, where .true. in element i
! indicates that i is a prime.
! =====================================================
    integer, intent(in)   :: n_max
    logical, intent(out)  :: is_prime(n_max)
    integer :: i
    is_prime = .true.
    is_prime(1) = .false.
    do i = 2, int(sqrt(real(n_max)))
        if (is_prime (i)) is_prime (i * i : n_max : i) = .false.
    end do
    return
end subroutine

subroutine logical_to_integer(prime_numbers, is_prime, num_primes, n)
! =====================================================
! Translates the logical array from sieve to an array
! of size num_primes of prime numbers.
! =====================================================
    integer                 :: i, j=0
    integer, intent(in)     :: n
    logical, intent(in)     :: is_prime(n)
    integer, intent(in)     :: num_primes
    integer, intent(out)    :: prime_numbers(num_primes)
    do i = 1, size(is_prime)
        if (is_prime(i)) then
            j = j + 1
            prime_numbers(j) = i
        end if
    end do
end subroutine


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief The global module for collecting all public members of
!> extended math routines.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE ExtendedMath

USE IntrType
USE Constants_Conversion
IMPLICIT NONE
PRIVATE

PUBLIC :: GAMMAF
PUBLIC :: Rational_Fraction
PUBLIC :: GreatestCommonDivisor
PUBLIC :: LeastCommonMultiple
PUBLIC :: ATAN2PI

INTERFACE LeastCommonMultiple
  MODULE PROCEDURE LeastCommonMultiple_scalar
  MODULE PROCEDURE LeastCommonMultiple_A1
ENDINTERFACE LeastCommonMultiple

CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Computes the GAMMA function
!> @param z a double precision real to compute the value of gamma for
!> @returns g the value of the GAMMA function at z
!>
!> This routine uses the Lanczos approximation to compute the gamma function
!> The coefficients @c p are the coefficients used by the GNU Scientific
!> Library. It is a double precision function and should be accurate to 15
!> digits of precision. It agrees with the intrinsic function supplied by the
!> Intel compiler.
!>
  PURE RECURSIVE FUNCTION GAMMAF(z) RESULT(g)
    INTEGER(SIK),PARAMETER :: cg=7
    REAL(SDK),DIMENSION(0:8),PARAMETER :: p=(/0.99999999999980993_SDK, &
        676.5203681218851_SDK,-1259.1392167224028_SDK,771.32342877765313_SDK, &
        -176.61502916214059_SDK,12.507343278686905_SDK, &
        -0.13857109526572012_SDK,9.9843695780195716e-6_SDK, &
        1.5056327351493116e-7_SDK/)
    REAL(SDK),INTENT(IN) :: z
    REAL(SDK) :: g
    INTEGER(SIK) :: i
    REAL(SDK) :: t,w,x

    x=z
    IF(x < 0.5_SDK) THEN
      g=PI/(SIN(PI*x)*GAMMAF(1.0_SDK-x))
    ELSE
      x=x-1.0_SDK
      t=p(0)
      DO i=1,cg+1
        t=t+p(i)/(x+REAL(i,SDK))
      ENDDO
      w=x+REAL(cg,SDK)+0.5_SDK
      g=SQRT(2.0_SDK*PI)*(w**(x+0.5_SDK))*EXP(-w)*t
    ENDIF
  ENDFUNCTION GAMMAF
!
!-------------------------------------------------------------------------------
!> @brief Computes a Rational Fraction less than a tolerance
!> @param targval a real which is the target value of the rational fraction
!> @param tol a real which is the tolerance for the rational fraction
!> @param num an integer which is the numerator of the rational fraction
!> @param denom an integer which is the denomenator of the rational fraction
!>
!> This routine calculates the rational fractions of a target value until the
!> fraction is less than a tolererance from the original value.  The rational
!> fraction calculation will stop after 50 iterations, which is an arbitrary
!> value that could easily be extended if tighter accuracy is required.  The
!> coeffiecients are stored such that:
!>    approx = c(0) + 1 / (c(1) + 1 / (c(2) + 1 / (c(3) +...)))
!>
SUBROUTINE Rational_Fraction(targval,tol,num,denom)
  REAL(SRK),INTENT(IN) :: targval
  REAL(SRK),INTENT(IN) :: tol
  INTEGER(SIK),INTENT(OUT) :: num
  INTEGER(SIK),INTENT(OUT) :: denom

  INTEGER(SIK) :: lev
  INTEGER(SIK) :: coef(50)
  REAL(SRK) :: targ

  coef=0

  targ=targval

  coef(1)=FLOOR(targ)
  targ=1.0_SRK/(targ-REAL(coef(1),SRK))
  DO lev=2,SIZE(coef)
    coef(lev)=FLOOR(targ)
    targ=1.0_SRK/(targ-REAL(coef(lev),SRK))
    num=coef(lev)
    denom=1
    CALL simplify_rat_frac(coef,lev,num,denom)
    IF(ABS(REAL(num,SRK)/REAL(denom,SRK)/targval-1.0_SRK) < tol) EXIT
  ENDDO
ENDSUBROUTINE Rational_Fraction
!
!-------------------------------------------------------------------------------
!> @brief Simplifies the rational fraction to a simple fraction
!> @param coef rational fraction coefficients in extended form
!> @param lev the index of coef of the maximum non-zero location
!> @param num an integer which is the numerator of the rational fraction
!> @param denom an integer which is the denomenator of the rational fraction
!>
!> This routine takes the exapanded coefficients of the rational fraction and
!> simplifies it to a single fraction:
!>    num / denom = c(0) + 1 / (c(1) + 1 / (c(2) + 1 / (c(3) +...)))
!>
RECURSIVE SUBROUTINE simplify_rat_frac(coef,lev,num,denom)
  INTEGER(SIK),INTENT(IN) :: coef(*)
  INTEGER(SIK),INTENT(IN) :: lev
  INTEGER(SIK),INTENT(INOUT) :: num
  INTEGER(SIK),INTENT(INOUT) :: denom

  INTEGER(SIK) :: tmpnum

  tmpnum=num
  num=coef(lev-1)*num+denom
  denom=tmpnum
  IF(lev > 2) THEN
    CALL simplify_rat_frac(coef,lev-1,num,denom)
  ENDIF
ENDSUBROUTINE simplify_rat_frac
!
!-------------------------------------------------------------------------------
!> @brief Calculates the Greatest Common Divisor
!> @param a1 an integer
!> @param a2 an integer
!> @returns b the greatest common divisor of a1 and a2
!>
!> This routine uses the Euclidean method to calculate the greatest common
!> divisor between two positive numbers.  If a negative number is input, the
!> resulting value is 0.
!>
ELEMENTAL FUNCTION GreatestCommonDivisor(a1,a2) RESULT(b)
  INTEGER(SIK),INTENT(IN) :: a1
  INTEGER(SIK),INTENT(IN) :: a2

  INTEGER(SIK) :: a,b,c

  a=0; b=0; c=0

  IF(a1 > 0 .AND. a2 > 0) THEN
    IF(a1 < a2) THEN
      a=a2
      b=a1
    ELSE
      a=a1
      b=a2
    ENDIF

    DO
      c=MOD(a,b)
      IF(c == 0) EXIT
      a=b
      b=c
    ENDDO
  ENDIF
ENDFUNCTION GreatestCommonDivisor
!
!-------------------------------------------------------------------------------
!> @brief solves for the least common multiple of an array of integers
!> @param u the array of integers to consider
!> @returns lcm the least common multiple of the array
!>
PURE FUNCTION LeastCommonMultiple_A1(u) RESULT(lcm)
  INTEGER(SIK),INTENT(IN) :: u(:)

  INTEGER(SIK) :: lcm
  INTEGER(SIK) :: i

  lcm = 0
  IF(SIZE(u) == 0) RETURN
  IF(ANY(u == 0)) RETURN

  lcm = abs(u(1))
  DO i=2,SIZE(u)
    !In all likelihood there exists an 'a' and 'b' which will cause overflow
    lcm = LeastCommonMultiple(lcm,u(i))
  ENDDO

ENDFUNCTION LeastCommonMultiple_A1
!
!-------------------------------------------------------------------------------
!> @brief solves for the least common multiple of a pair of integers
!> @param u the first integer to consider
!> @param v the second integer to consider
!> @returns lcm the least common multiple of the array
!>
ELEMENTAL FUNCTION LeastCommonMultiple_scalar(u,v) RESULT(lcm)
  INTEGER(SIK),INTENT(IN) :: u
  INTEGER(SIK),INTENT(IN) :: v

  INTEGER(SIK) :: lcm
  INTEGER(SIK) :: a,b

  lcm = 0
  IF(u == 0 .OR. v == 0) RETURN
  a = ABS(u)
  b = ABS(v)

  IF(a == b) THEN
    lcm = a
  ELSE
    !In all likelihood there exists an 'a' and 'b' which will cause overflow
    lcm = (a/GreatestCommonDivisor(a,b)) * b
  ENDIF
ENDFUNCTION LeastCommonMultiple_scalar
!
!-------------------------------------------------------------------------------
!> @brief Calculates the angle from the origin to (x,y) from the +(x-axis) on
!> [0,2pi)
!> @param x the x-coordinate
!> @param y the y-coordinate
!> @returns theta the angle formed by the point (x,y) w.r.t. the positive x-axis
!> on [0,2PI)
!>
!> This routine calls ATAN2 and casts the result to exist on [0,2pi). It is
!> useful, since we often need to sort points by angle in the entire unit circle
!> and the discontinuity at pi that is generated by the native ATAN2 function is
!> inconvenient.
!>
ELEMENTAL FUNCTION ATAN2PI(x,y) RESULT(theta)
  REAL(SRK),INTENT(IN) :: x
  REAL(SRK),INTENT(IN) :: y
  REAL(SRK) :: theta,xx,yy
  xx=x
  IF(x .APPROXEQA. 0.0_SRK) xx=0.0_SRK
  yy=y
  IF(y .APPROXEQA. 0.0_SRK) yy=0.0_SRK
  theta=ATAN2(yy,xx)
  IF(.NOT.(theta .APPROXGE. 0.0_SRK)) theta=TWOPI+theta
ENDFUNCTION ATAN2PI
!
ENDMODULE ExtendedMath


      MODULE stel_constants

      USE stel_kinds

!----------------------------------------------------------------------
!  Mathematical constants
!----------------------------------------------------------------------

      REAL(rprec), PARAMETER :: pi=3.14159265358979323846264338328_rprec
      REAL(rprec), PARAMETER :: pio2=1.570796326794896619231321691_rprec
      REAL(rprec), PARAMETER :: twopi=6.28318530717958647692528677_rprec
      REAL(rprec), PARAMETER :: sqrt2=1.41421356237309504880168872_rprec
      REAL(rprec), PARAMETER :: degree = twopi / 360
      REAL(rprec), PARAMETER :: one = 1.0_rprec
      REAL(rprec), PARAMETER :: zero = 0.0_rprec

!----------------------------------------------------------------------
!  Physical constants
!------------------------------------------------------------------

      REAL(rprec), PARAMETER :: mu0 = 2 * twopi * 1.0e-7_rprec

      END MODULE stel_constants


submodule(forlab_linalg) forlab_linalg_inv

    implicit none

contains

    module procedure inv_rsp
    !! inv0 computes the real matrix inverse.
    integer :: i, j, k, m
    real(sp) :: D
    real(sp), dimension(:), allocatable :: x, y, e
    real(sp), dimension(:, :), allocatable :: L, U

    if (is_square(A)) then
        m = size(A, 1)
        if (m .le. 3) then
            D = det(A)
        else
            D = det(A, L, U)
        end if
        if (D .ne. 0._sp) then
            inv = zeros(m, m)
            if (m .eq. 2) then
                inv(1, 1) = A(2, 2)
                inv(1, 2) = -A(1, 2)
                inv(2, 1) = -A(2, 1)
                inv(2, 2) = A(1, 1)
                inv = inv/D
            elseif (m .eq. 3) then
                inv(1, 1) = A(2, 2)*A(3, 3) - A(2, 3)*A(3, 2)
                inv(1, 2) = A(1, 3)*A(3, 2) - A(1, 2)*A(3, 3)
                inv(1, 3) = A(1, 2)*A(2, 3) - A(1, 3)*A(2, 2)
                inv(2, 1) = A(2, 3)*A(3, 1) - A(2, 1)*A(3, 3)
                inv(2, 2) = A(1, 1)*A(3, 3) - A(1, 3)*A(3, 1)
                inv(2, 3) = A(1, 3)*A(2, 1) - A(1, 1)*A(2, 3)
                inv(3, 1) = A(2, 1)*A(3, 2) - A(2, 2)*A(3, 1)
                inv(3, 2) = A(1, 2)*A(3, 1) - A(1, 1)*A(3, 2)
                inv(3, 3) = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1)
                inv = inv/D
            else
                do k = 1, m
                    x = zeros(m)
                    y = zeros(m)
                    e = zeros(m)
                    e(k) = 1.
                    y(1) = e(1)

                    ! Forward substitution: Ly = e
                    !==============================
                    do i = 2, m
                        y(i) = e(i)
                        do j = 1, i - 1
                            y(i) = y(i) - y(j)*L(i, j)
                        end do
                    end do

                    ! Back substitution: Ux = y
                    !===========================
                    x(m) = y(m)/U(m, m)
                    do i = m - 1, 1, -1
                        x(i) = y(i)
                        do j = m, i + 1, -1
                            x(i) = x(i) - x(j)*U(i, j)
                        end do
                        x(i) = x(i)/U(i, i)
                    end do

                    ! The column k of the inverse is x
                    !==================================
                    inv(:, k) = x
                end do
            end if
        else
            call error_stop("Error: in det(A), A is not inversible (= 0).")
        end if
    else
        call error_stop("Error: in inv(A), A should be square.")
    end if
    return
    end procedure
    module procedure inv_rdp
    !! inv0 computes the real matrix inverse.
    integer :: i, j, k, m
    real(dp) :: D
    real(dp), dimension(:), allocatable :: x, y, e
    real(dp), dimension(:, :), allocatable :: L, U

    if (is_square(A)) then
        m = size(A, 1)
        if (m .le. 3) then
            D = det(A)
        else
            D = det(A, L, U)
        end if
        if (D .ne. 0._dp) then
            inv = zeros(m, m)
            if (m .eq. 2) then
                inv(1, 1) = A(2, 2)
                inv(1, 2) = -A(1, 2)
                inv(2, 1) = -A(2, 1)
                inv(2, 2) = A(1, 1)
                inv = inv/D
            elseif (m .eq. 3) then
                inv(1, 1) = A(2, 2)*A(3, 3) - A(2, 3)*A(3, 2)
                inv(1, 2) = A(1, 3)*A(3, 2) - A(1, 2)*A(3, 3)
                inv(1, 3) = A(1, 2)*A(2, 3) - A(1, 3)*A(2, 2)
                inv(2, 1) = A(2, 3)*A(3, 1) - A(2, 1)*A(3, 3)
                inv(2, 2) = A(1, 1)*A(3, 3) - A(1, 3)*A(3, 1)
                inv(2, 3) = A(1, 3)*A(2, 1) - A(1, 1)*A(2, 3)
                inv(3, 1) = A(2, 1)*A(3, 2) - A(2, 2)*A(3, 1)
                inv(3, 2) = A(1, 2)*A(3, 1) - A(1, 1)*A(3, 2)
                inv(3, 3) = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1)
                inv = inv/D
            else
                do k = 1, m
                    x = zeros(m)
                    y = zeros(m)
                    e = zeros(m)
                    e(k) = 1.
                    y(1) = e(1)

                    ! Forward substitution: Ly = e
                    !==============================
                    do i = 2, m
                        y(i) = e(i)
                        do j = 1, i - 1
                            y(i) = y(i) - y(j)*L(i, j)
                        end do
                    end do

                    ! Back substitution: Ux = y
                    !===========================
                    x(m) = y(m)/U(m, m)
                    do i = m - 1, 1, -1
                        x(i) = y(i)
                        do j = m, i + 1, -1
                            x(i) = x(i) - x(j)*U(i, j)
                        end do
                        x(i) = x(i)/U(i, i)
                    end do

                    ! The column k of the inverse is x
                    !==================================
                    inv(:, k) = x
                end do
            end if
        else
            call error_stop("Error: in det(A), A is not inversible (= 0).")
        end if
    else
        call error_stop("Error: in inv(A), A should be square.")
    end if
    return
    end procedure

    module procedure inv_csp
    !! inv computes the complex matrix inverse.
    real(sp), dimension(:, :), allocatable :: ar, ai
    !! AR stores the real part, AI stores the imaginary part
    integer :: flag, n
    real(sp) :: d, p, t, q, s, b
    integer, dimension(:), allocatable :: is, js
    integer :: i, j, k

    if (is_square(A)) then
        n = size(A, 1)
        inv = zeros(n, n)
        ar = zeros(n, n)
        ai = zeros(n, n)

        is = ones(n)
        js = ones(n)

        forall (i=1:n, j=1:n)
            ar(i, j) = real(A(i, j)); ai(i, j) = imag(A(i, j))
        end forall
        flag = 1
        do k = 1, n
            d = 0.0
            do i = k, n
                do j = k, n
                    p = ar(i, j)*ar(i, j) + ai(i, j)*ai(i, j)
                    if (p .gt. d) then
                        d = p
                        is(k) = i
                        js(k) = j
                    end if
                end do
            end do
            if (d + 1.0_sp .eq. 1.0_sp) then
                flag = 0
                call error_stop('ERROR: A is not inversible (= 0)')
            end if
            do j = 1, n
                t = ar(k, j)
                ar(k, j) = ar(is(k), j)
                ar(is(k), j) = t
                t = ai(k, j)
                ai(k, j) = ai(is(k), j)
                ai(is(k), j) = t
            end do
            do i = 1, n
                t = ar(i, k)
                ar(i, k) = ar(i, js(k))
                ar(i, js(k)) = t
                t = ai(i, k)
                ai(i, k) = ai(i, js(k))
                ai(i, js(k)) = t
            end do
            ar(k, k) = ar(k, k)/d
            ai(k, k) = -ai(k, k)/d
            do j = 1, n
                if (j .ne. k) then
                    p = ar(k, j)*ar(k, k)
                    q = ai(k, j)*ai(k, k)
                    s = (ar(k, j) + ai(k, j))*(ar(k, k) + ai(k, k))
                    ar(k, j) = p - q
                    ai(k, j) = s - p - q
                end if
            end do
            do i = 1, n
                if (i .ne. k) then
                    do j = 1, n
                        if (j .ne. k) then
                            p = ar(k, j)*ar(i, k)
                            q = ai(k, j)*ai(i, k)
                            s = (ar(k, j) + ai(k, j))*(ar(i, k) + ai(i, k))
                            t = p - q
                            b = s - p - q
                            ar(i, j) = ar(i, j) - t
                            ai(i, j) = ai(i, j) - b
                        end if
                    end do
                end if
            end do
            do i = 1, n
                if (i .ne. k) then
                    p = ar(i, k)*ar(k, k)
                    q = ai(i, k)*ai(k, k)
                    s = (ar(i, k) + ai(i, k))*(ar(k, k) + ai(k, k))
                    ar(i, k) = q - p
                    ai(i, k) = p + q - s
                end if
            end do
        end do
        do k = n, 1, -1
            do j = 1, n
                t = ar(k, j)
                ar(k, j) = ar(js(k), j)
                ar(js(k), j) = t
                t = ai(k, j)
                ai(k, j) = ai(js(k), j)
                ai(js(k), j) = t
            end do
            do i = 1, n
                t = ar(i, k)
                ar(i, k) = ar(i, is(k))
                ar(i, is(k)) = t
                t = ai(i, k)
                ai(i, k) = ai(i, is(k))
                ai(i, is(k)) = t
            end do
        end do
        forall (i=1:n, j=1:n)
            inv(i, j) = cmplx(ar(i, j), ai(i, j), sp)
        end forall
    else
        call error_stop('Error: in inv(A), A should be square.')
    end if
    return
    end procedure inv_csp
    module procedure inv_cdp
    !! inv computes the complex matrix inverse.
    real(dp), dimension(:, :), allocatable :: ar, ai
    !! AR stores the real part, AI stores the imaginary part
    integer :: flag, n
    real(dp) :: d, p, t, q, s, b
    integer, dimension(:), allocatable :: is, js
    integer :: i, j, k

    if (is_square(A)) then
        n = size(A, 1)
        inv = zeros(n, n)
        ar = zeros(n, n)
        ai = zeros(n, n)

        is = ones(n)
        js = ones(n)

        forall (i=1:n, j=1:n)
            ar(i, j) = real(A(i, j)); ai(i, j) = imag(A(i, j))
        end forall
        flag = 1
        do k = 1, n
            d = 0.0
            do i = k, n
                do j = k, n
                    p = ar(i, j)*ar(i, j) + ai(i, j)*ai(i, j)
                    if (p .gt. d) then
                        d = p
                        is(k) = i
                        js(k) = j
                    end if
                end do
            end do
            if (d + 1.0_dp .eq. 1.0_dp) then
                flag = 0
                call error_stop('ERROR: A is not inversible (= 0)')
            end if
            do j = 1, n
                t = ar(k, j)
                ar(k, j) = ar(is(k), j)
                ar(is(k), j) = t
                t = ai(k, j)
                ai(k, j) = ai(is(k), j)
                ai(is(k), j) = t
            end do
            do i = 1, n
                t = ar(i, k)
                ar(i, k) = ar(i, js(k))
                ar(i, js(k)) = t
                t = ai(i, k)
                ai(i, k) = ai(i, js(k))
                ai(i, js(k)) = t
            end do
            ar(k, k) = ar(k, k)/d
            ai(k, k) = -ai(k, k)/d
            do j = 1, n
                if (j .ne. k) then
                    p = ar(k, j)*ar(k, k)
                    q = ai(k, j)*ai(k, k)
                    s = (ar(k, j) + ai(k, j))*(ar(k, k) + ai(k, k))
                    ar(k, j) = p - q
                    ai(k, j) = s - p - q
                end if
            end do
            do i = 1, n
                if (i .ne. k) then
                    do j = 1, n
                        if (j .ne. k) then
                            p = ar(k, j)*ar(i, k)
                            q = ai(k, j)*ai(i, k)
                            s = (ar(k, j) + ai(k, j))*(ar(i, k) + ai(i, k))
                            t = p - q
                            b = s - p - q
                            ar(i, j) = ar(i, j) - t
                            ai(i, j) = ai(i, j) - b
                        end if
                    end do
                end if
            end do
            do i = 1, n
                if (i .ne. k) then
                    p = ar(i, k)*ar(k, k)
                    q = ai(i, k)*ai(k, k)
                    s = (ar(i, k) + ai(i, k))*(ar(k, k) + ai(k, k))
                    ar(i, k) = q - p
                    ai(i, k) = p + q - s
                end if
            end do
        end do
        do k = n, 1, -1
            do j = 1, n
                t = ar(k, j)
                ar(k, j) = ar(js(k), j)
                ar(js(k), j) = t
                t = ai(k, j)
                ai(k, j) = ai(js(k), j)
                ai(js(k), j) = t
            end do
            do i = 1, n
                t = ar(i, k)
                ar(i, k) = ar(i, is(k))
                ar(i, is(k)) = t
                t = ai(i, k)
                ai(i, k) = ai(i, is(k))
                ai(i, is(k)) = t
            end do
        end do
        forall (i=1:n, j=1:n)
            inv(i, j) = cmplx(ar(i, j), ai(i, j), dp)
        end forall
    else
        call error_stop('Error: in inv(A), A should be square.')
    end if
    return
    end procedure inv_cdp

end submodule forlab_linalg_inv


	subroutine estimate_ksat(perc_clay,esti_ksat)

!!	This subroutine calculates ksat value for a soil layer
!!	given the % of clay in the soil layer

!!	Background: Published work of Walter Rawls- calculated
!!	ksat values  based on soil texture (sand,silt and clay)
!!	idea: there exists a relationship between % clay and Ksat
!!	Equations used in this subroutine are based on the above
!!	idea (Jimmy willimas).

!!	NK June 28,2006

	implicit none

	integer::i,eof
	real::esti_ksat,perc_clay,xc,exksat
	exksat=5.0

!	print *,"Enter the % clay in the soil layer"
!	read *,perc_clay

	xc=100.0-perc_clay
	esti_ksat=12.7*xc/(xc+exp(11.45-0.097*xc))+1.0

!	print *,"The estimated ksat value is ",min(esti_ksat,exksat)

	return

	end subroutine estimate_ksat


module euler_utils_m
    use iso_fortran_env, only: int64, real32, real64
    implicit none
    private

    integer, parameter, public :: sp = real32, dp = real64
    real(sp), parameter, public :: tiny_sp = tiny(0._sp)
    real(dp), parameter, public :: tiny_dp = tiny(0._dp)

    public :: unit_digit, swap, digs_of_int, is_pandigital
    public :: fibonacci, reverse, is_palindromic, gcd, lcm, factorial
    public :: int_2_arr, arr_2_int, append, next_permutation

    !> A generic interface that returns the unit digit of an integer.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, unit_digit(324) ! 4
    !>    print *, unit_digit(543212345_int64) ! 5
    !>end program main
    !>```
    interface unit_digit
        module procedure unit_digit_int32
        module procedure unit_digit_int64
    end interface unit_digit

    !> A generic interface that swap two elements (the two elements
    !> have to be the same type. When swapping two character types,
    !> the two character variables must have the same length.).
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: a, b
    !>    a = 32; b = 23
    !>    print *, a, b ! 32, 23
    !>    call swap(a, b)
    !>    print *, a, b ! 23, 32
    !>end program main
    !>```
    interface swap
        module procedure swap_sp, swap_dp
        module procedure swap_int32, swap_int64
        module procedure swap_equal_len_char
    end interface swap

    !> A generic interface that returns the length of an integer.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    user euler_utils_m
    !>    implicit none
    !>
    !>    print *, digs_of_int(12345) ! 5
    !>    print *, digs_of_int(1234567890_int64) ! 10
    !>end program main
    !>```
    interface digs_of_int
        module procedure digs_of_int_int32
        module procedure digs_of_int_int64
    end interface digs_of_int

    !> A generic interface that returns the nth fibonacci number.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, fibonacci(12) ! 144
    !>    print *, fibonacci(12_int64) ! 144
    !>end program main
    !>```
    interface fibonacci
        module procedure fib32, fib64
    end interface fibonacci

    !> A generic interface that reverse the digits of an integer.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, reverse(12345) ! 54321
    !>    print *, reverse(12345_int64) ! 54321
    !>end program main
    !>```
    interface reverse
        module procedure reverse_int32, reverse_int64
    end interface reverse

    !> A generic interface that tells if an integer is a palindromic integer.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: a = 123454321, b = 1234
    !>    print *, is_palindromic(a) ! T
    !>    print *, is_palindromic(b) ! F
    !>end program main
    !>```
    interface is_palindromic
        module procedure is_palindromic_int32
        module procedure is_palindromic_int64
    end interface is_palindromic

    !> Greatest common divisor.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, gcd(32, 24) ! 8
    !>    print *, gcd(32_int64, 24_int64) ! 8
    !>end program main
    !>```
    interface gcd
        module procedure gcd_int32, gcd_int64
    end interface gcd

    !> Least common multiple.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, lcm(3, 4) ! 12
    !>    print *, lcm(3_int64, 4_int64) ! 12
    !>end program main
    !>```
    interface lcm
        module procedure lcm_int32, lcm_int64
    end interface lcm

    !> Factorial.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, factorial(4) ! 24
    !>    print *, factorial(4_int64) ! 24
    !>end program main
    !>```
    interface factorial
        module procedure factorial_int32
        module procedure factorial_int64
    end interface factorial

    !> To judge whether an integer is a pandigital number.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    print *, is_pandigital(1023456789) ! T
    !>end program main
    !>```
    interface is_pandigital
        module procedure is_pandigital_int32
        module procedure is_pandigital_int64
    end interface is_pandigital

    !> Convert integer to an integer array.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: a = 234
    !>    integer, allocatable :: arr(:)
    !>
    !>    call int_2_arr(a, arr)
    !>    print *, arr ! [2, 3, 4]
    !>end program main
    !>```
    interface int_2_arr
        module procedure int_2_arr_int32
        module procedure int_2_arr_int64
    end interface int_2_arr

    !> Convert an integer arr to an integer.
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: arr(3) = [2, 3, 4]
    !>    integer :: a
    !>
    !>    call arr_2_int(arr, a)
    !>    print *, a ! 234
    !>end program main
    !>```
    interface arr_2_int
        module procedure arr_2_int_int32
        module procedure arr_2_int_int64
    end interface arr_2_int

    !> Append an element to the end of an array
    !>
    !>### Usage
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer, allocatable :: arr(:)
    !>
    !>    arr = [1, 2, 3]
    !>    call append(arr, 4)
    !>    print *, arr ! [1, 2, 3, 4]
    !>end program main
    !>```
    interface append
        module procedure append_sp, append_dp
        module procedure append_int32, append_int64
    end interface append

    !> An interface of variant permutation functions
    !>
    !>### Usage
    !>#### `next_permutation_int32/int64` (k-permutation of n)
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: k, n
    !>    integer, dimesion(2) :: arr
    !>    logical :: next_permutation_available
    !>
    !>    k = 2; n = 3
    !>    arr = [1, 2]
    !>    next_permutation_available = .true.
    !>
    !>    do while (next_permutation_available)
    !>        print *, arr
    !>        call permutation(k, n, arr, next_permutation_available)
    !>    end do
    !>    ! Output: (1, 2), (1, 3), and (2, 3).
    !>end program main
    !>```
    !>
    !>#### `next_permutation2_int32` (permutation)
    !>```fortran
    !>program main
    !>    use euler_utils_m
    !>    implicit none
    !>
    !>    integer :: arr(3)
    !>    logical :: next_permutation_available
    !>
    !>    arr = [1, 2, 3]
    !>    next_permutation_available = .true.
    !>
    !>    do while (next_permutation_available)
    !>        print *, arr
    !>        call permutation(arr, next_permutation_available)
    !>    end do
    !>    ! Output: (1, 2, 3), (1, 3, 2), (2, 1, 3), (2, 3, 1),
    !>    ! (3, 1, 2), and (3, 2, 1).
    !>end program main
    !>```
    interface next_permutation
        module procedure next_permutation_int32
        module procedure next_permutation_int64
        module procedure next_permutation2_int32
    end interface next_permutation

contains

    pure integer function unit_digit_int32(n)
        integer, intent(in) :: n
        unit_digit_int32 = mod(n, 10)
    end function unit_digit_int32

    pure integer(int64) function unit_digit_int64(n)
        integer(int64), intent(in) :: n
        unit_digit_int64 = mod(n, 10_int64)
    end function unit_digit_int64

    pure subroutine swap_sp(a, b)
        real(sp), intent(inout) :: a, b
        real(sp) :: tmp

        tmp = a; a = b; b = tmp
    end subroutine swap_sp

    pure subroutine swap_dp(a, b)
        real(dp), intent(inout) :: a, b
        real(dp) :: tmp

        tmp = a; a = b; b = tmp
    end subroutine swap_dp

    pure subroutine swap_int32(a, b)
        integer, intent(inout) :: a, b
        integer :: tmp

        tmp = a; a = b; b = tmp
    end subroutine swap_int32

    pure subroutine swap_int64(a, b)
        integer(int64), intent(inout) :: a, b
        integer(int64) :: tmp

        tmp = a; a = b; b = tmp
    end subroutine swap_int64

    pure subroutine swap_equal_len_char(a, b)
        character(len=*), intent(inout) :: a
        character(len=len(a)), intent(inout) :: b
        character(len=len(a)) :: tmp

        tmp = a
        a = b
        b = tmp
    end subroutine swap_equal_len_char

    pure integer function digs_of_int_int32(n)
        integer, intent(in) :: n

        digs_of_int_int32 = floor(log10(real(n, sp))) + 1
    end function digs_of_int_int32

    pure integer(int64) function digs_of_int_int64(n)
        integer(int64), intent(in) :: n

        digs_of_int_int64 = floor(log10(real(n, sp))) + 1_int64
    end function digs_of_int_int64

    pure recursive function fib32(n) result(ans)
        integer, intent(in) :: n
        integer :: k, ans

        if (n < 0 .or. n > 92) then
            error stop "fib32: Invalid input number."
        end if

        if (n == 0) then
            ans = 0
        else if (n == 1 .or. n == 2) then
            ans = 1
        else if (mod(n, 2) == 0) then
            k = n/2
            ans = fib32(k)*(fib32(k + 1)*2 - fib32(k))
        else
            k = (n - 1)/2
            ans = fib32(k + 1)**2 + fib32(k)**2
        end if
    end function fib32

    pure recursive function fib64(n) result(ans)
        integer(int64), intent(in) :: n
        integer(int64) :: k, ans

        if (n < 0_int64 .or. n > 92_int64) then
            error stop "fib64: Invalid input number."
        end if

        if (n == 0_int64) then
            ans = 0_int64
        else if (n == 1_int64 .or. n == 2_int64) then
            ans = 1_int64
        else if (mod(n, 2_int64) == 0_int64) then
            k = n/2_int64
            ans = fib64(k)*(fib64(k + 1_int64)*2_int64 - fib64(k))
        else
            k = (n - 1_int64)/2_int64
            ans = fib64(k + 1_int64)**2_int64 + fib64(k)**2_int64
        end if
    end function fib64

    pure integer function reverse_int32(n)
        integer, intent(in) :: n
        integer :: reversed, tmp

        reversed = 0; tmp = n
        do while (tmp > 0)
            reversed = reversed*10 + mod(tmp, 10)
            tmp = tmp/10
        end do
        reverse_int32 = reversed
    end function reverse_int32

    pure integer(int64) function reverse_int64(n)
        integer(int64), intent(in) :: n
        integer(int64) :: reversed, tmp
        reversed = 0_int64; tmp = n
        do while (tmp > 0_int64)
            reversed = reversed*10_int64 + mod(tmp, 10_int64)
            tmp = tmp/10_int64
        end do
        reverse_int64 = reversed
    end function reverse_int64

    pure logical function is_palindromic_int32(n)
        integer, intent(in) :: n

        is_palindromic_int32 = .false.
        if (n == reverse_int32(n)) then
            is_palindromic_int32 = .true.
        end if
    end function is_palindromic_int32

    pure logical function is_palindromic_int64(n)
        integer(int64), intent(in) :: n

        is_palindromic_int64 = .false.
        if (n == reverse_int64(n)) then
            is_palindromic_int64 = .true.
        end if
    end function is_palindromic_int64

    pure recursive function gcd_int32(n1, n2) result(ans)
        integer, intent(in) :: n1, n2
        integer :: ans

        if (n2 == 0) then
            ans = n1
        else
            ans = gcd_int32(n2, mod(n1, n2))
        end if
    end function gcd_int32

    pure recursive function gcd_int64(n1, n2) result(ans)
        integer(int64), intent(in) :: n1, n2
        integer(int64) :: ans

        if (n2 == 0_int64) then
            ans = n1
        else
            ans = gcd_int64(n2, mod(n1, n2))
        end if
    end function gcd_int64

    pure integer function lcm_int32(n1, n2)
        integer, intent(in) :: n1, n2

        lcm_int32 = n1*n2/gcd_int32(n1, n2)
    end function lcm_int32

    pure integer(int64) function lcm_int64(n1, n2)
        integer(int64), intent(in) :: n1, n2

        lcm_int64 = n1*n2/gcd_int64(n1, n2)
    end function lcm_int64

    pure integer function factorial_int32(n)
        integer, intent(in) :: n
        integer :: i, tmp

        if (n >= 13) then
            error stop "FACTORIAL_INT32: n >= 13."
        end if

        tmp = 1
        do i = 1, n
            tmp = tmp*i
        end do
        factorial_int32 = tmp
    end function factorial_int32

    pure integer(int64) function factorial_int64(n)
        integer(int64), intent(in) :: n
        integer(int64) :: i, tmp

        if (n >= 13_int64) then
            error stop "FACTORIAL_INT32: n >= 13."
        end if

        tmp = 1_int64
        do i = 1_int64, n
            tmp = tmp*i
        end do
        factorial_int64 = tmp
    end function factorial_int64

    pure logical function is_pandigital_int32(n, digs)
        integer, intent(in) :: n
        integer, intent(in), optional :: digs
        integer :: tmp, j, l
        logical, allocatable :: logic_arr(:)

        if (present(digs)) then
            allocate (logic_arr(digs))
            l = digs
        else
            l = 9
            allocate (logic_arr(l))
        end if

        is_pandigital_int32 = .false.
        logic_arr = .false.
        tmp = n

        do
            j = unit_digit_int32(tmp)
            if (j == 0 .or. j > l) exit
            logic_arr(j) = .true.
            tmp = tmp/10
        end do

        if (count(logic_arr) == l) then
            is_pandigital_int32 = .true.
        else
            is_pandigital_int32 = .false.
        end if
    end function is_pandigital_int32

    pure logical function is_pandigital_int64(n, digs)
        integer(int64), intent(in) :: n
        integer(int64), intent(in), optional :: digs
        integer(int64) :: tmp, j, l
        logical, allocatable :: logic_arr(:)

        if (present(digs)) then
            allocate (logic_arr(digs))
            l = digs
        else
            l = 9_int64
            allocate (logic_arr(l))
        end if

        is_pandigital_int64 = .false.
        logic_arr = .false.
        tmp = n

        do
            j = unit_digit_int64(tmp)
            if (j == 0_int64 .or. j > l) exit
            logic_arr(j) = .true.
            tmp = tmp/10_int64
        end do

        if (count(logic_arr) == l) then
            is_pandigital_int64 = .true.
        else
            is_pandigital_int64 = .false.
        end if
    end function is_pandigital_int64

    pure subroutine int_2_arr_int32(n, arr)
        integer, intent(in) :: n
        integer, allocatable, intent(out) :: arr(:)
        integer :: tmp, i, l

        tmp = n
        l = digs_of_int_int32(tmp)

        if (l == 1) then
            allocate (arr(1))
            arr(1) = n
            return
        end if

        allocate (arr(l))
        do i = l, 1, -1
            arr(i) = unit_digit_int32(tmp)
            tmp = tmp/10
        end do
    end subroutine int_2_arr_int32

    pure subroutine int_2_arr_int64(n, arr)
        integer(int64), intent(in) :: n
        integer, allocatable, intent(out) :: arr(:)
        integer(int64) :: tmp
        integer :: i, l

        tmp = n
        l = int(digs_of_int_int64(tmp))

        if (l == 1) then
            allocate (arr(1))
            arr(1) = int(n)
            return
        end if

        allocate (arr(l))
        do i = l, 1, -1
            arr(i) = int(unit_digit_int64(tmp))
            tmp = tmp/10_int64
        end do
    end subroutine int_2_arr_int64

    pure subroutine arr_2_int_int32(arr, n)
        integer, intent(in) :: arr(:)
        integer, intent(out) :: n
        integer :: i, tmp, l

        l = size(arr, dim=1)
        tmp = 0

        do i = 1, l
            tmp = tmp*10 + arr(i)
        end do

        n = tmp
    end subroutine arr_2_int_int32

    pure subroutine arr_2_int_int64(arr, n)
        integer(int64), intent(in) :: arr(:)
        integer(int64), intent(out) :: n
        integer(int64) :: i, tmp, l

        l = size(arr, dim=1)
        tmp = 0_int64

        do i = 1_int64, l
            tmp = tmp*10_int64 + arr(i)
        end do

        n = tmp
    end subroutine arr_2_int_int64

    pure subroutine append_sp(arr, e)
        real(sp), allocatable, intent(inout) :: arr(:)
        real(sp), intent(in) :: e

        if (allocated(arr)) then
            arr = [arr, [e]]
        else
            arr = [e]
        end if
    end subroutine append_sp

    pure subroutine append_dp(arr, e)
        real(dp), allocatable, intent(inout) :: arr(:)
        real(dp), intent(in) :: e

        if (allocated(arr)) then
            arr = [arr, [e]]
        else
            arr = [e]
        end if
    end subroutine append_dp

    pure subroutine append_int32(arr, e)
        integer, allocatable, intent(inout) :: arr(:)
        integer, intent(in) :: e

        if (allocated(arr)) then
            arr = [arr, [e]]
        else
            arr = [e]
        end if
    end subroutine append_int32

    pure subroutine append_int64(arr, e)
        integer(int64), allocatable, intent(inout) :: arr(:)
        integer(int64), intent(in) :: e

        if (allocated(arr)) then
            arr = [arr, [e]]
        else
            arr = [e]
        end if
    end subroutine append_int64

    pure subroutine next_permutation_int32(k, n, idx, next_permutation_avail)
        integer, intent(in) :: k, n
        integer, intent(inout) :: idx(k)
        logical, intent(out) :: next_permutation_avail
        logical :: carr(k)
        integer :: i, x, end_arr(k)

        end_arr = [(i, i=n - k + 1, n)]
        next_permutation_avail = .true.
        if (all(idx == end_arr)) then
            next_permutation_avail = .false.
            return
        end if

        carr = .true.
        label_carry: do i = k, 1, -1
            if (idx(i) == n - k + i) carr(i) = .false.
        end do label_carry

        if (all(carr .eqv. .true.)) then
            idx(k) = idx(k) + 1
        else
            x = findloc(carr, value=.false., dim=1) - 1
            idx(x:k) = [(idx(x) + i, i=1, k - x + 1)]
        end if
    end subroutine next_permutation_int32

    pure subroutine next_permutation_int64(k, n, idx, next_permutation_avail)
        integer(int64), intent(in) :: k, n
        integer(int64), intent(inout) :: idx(k)
        logical, intent(out) :: next_permutation_avail
        logical :: carr(k)
        integer(int64) :: i, x, end_arr(k)

        end_arr = [(i, i=n - k + 1, n)]
        next_permutation_avail = .true.
        if (all(idx == end_arr)) then
            next_permutation_avail = .false.
            return
        end if

        carr = .true.
        label_carry: do i = k, 1, -1
            if (idx(i) == n - k + i) carr(i) = .false.
        end do label_carry

        if (all(carr .eqv. .true.)) then
            idx(k) = idx(k) + 1
        else
            x = findloc(carr, value=.false., dim=1) - 1
            idx(x:k) = [(idx(x) + i, i=1, k - x + 1)]
        end if
    end subroutine next_permutation_int64

    pure subroutine next_permutation2_int32(arr, next_permutation_avail)
        integer, intent(inout) :: arr(:)
        logical, intent(out) :: next_permutation_avail
        integer :: i, k, l

        k = 0; l = 0
        do i = size(arr) - 1, 1, -1
            if (arr(i) < arr(i + 1)) then
                k = i
                next_permutation_avail = .true.
                exit
            else
                next_permutation_avail = .false.
            end if
        end do

        do i = size(arr), 1, -1
            if (arr(k) < arr(i)) then
                l = i; exit
            end if
        end do

        call swap(arr(k), arr(l))
        arr(k + 1:size(arr)) = arr(size(arr):k + 1:-1)
    end subroutine next_permutation2_int32

end module euler_utils_m


SUBROUTINE UNBIASED_CORRELATION( N, A, B, msg, lag, r, t, m)

  ! Computes the correlation of two series A and B of length
  ! N as a function of lag. The correlation is unbiased
  ! because the sums in the covariance and standard devia-
  ! tions are divided by m, not m-1, where m is the number
  ! of overlapping grid points.

  ! The correlation r is defined as
  !
  !           cov(A,B)
  !     r = -------------
  !          s(A) * s(B)
  !
  ! where cov() is covariance and s() is standard deviation.

  ! The series A and B must be prepared such that they
  ! are sent to this routine with zero lag. If necessary, this
  ! is accomplished by padding the beginning or ends (or both)
  ! of each time series with missing values (msg) so that their
  ! elements correspond one to one. The resultant time series
  ! will be of equal length N. Also, missing values (msg)
  ! distributed thoughout each time series is perfectly
  ! acceptable. Time series B will be shifted by the amount
  ! lag relative to time series A:

  ! RETURNS: r, the unbiased correlation, t, the significance
  ! of the unbiased correlation ( t is set to msg if B = A
  ! at lag 0, i.e. an autocorrelation at lag 0, or if the
  ! correlation is 1.0 in general), and m, the number of
  ! overlapping grid points.

  ! A:      t1  t2  t3  t4        ...       tN
  ! B:              t1  t2  t3  t4        ...       tN

  !         \_ _/
  !           V
  !           lag = 2 (Defined to be > 0.)

  IMPLICIT NONE

  INTEGER, INTENT(IN)                :: N
  REAL(8), DIMENSION(N), INTENT(IN)  :: A
  REAL(8), DIMENSION(N), INTENT(IN)  :: B
  REAL(8), INTENT(IN)                :: msg
  INTEGER, INTENT(IN)                :: lag
  REAL(8), INTENT(OUT)               :: r
  REAL(8), INTENT(OUT)               :: t
  INTEGER, INTENT(OUT)               :: m

  REAL(8), DIMENSION(:), ALLOCATABLE :: x
  REAL(8), DIMENSION(:), ALLOCATABLE :: y
  REAL(8), DIMENSION(:), ALLOCATABLE :: xdev
  REAL(8), DIMENSION(:), ALLOCATABLE :: ydev
  REAL(8), DIMENSION(:), ALLOCATABLE :: xdevydev
  REAL(8), DIMENSION(:), ALLOCATABLE :: xdevxdev
  REAL(8), DIMENSION(:), ALLOCATABLE :: ydevydev

  REAL(8)                            :: xmn
  REAL(8)                            :: ymn
  REAL(8)                            :: COVxy
  REAL(8)                            :: Sx
  REAL(8)                            :: Sy

  ALLOCATE( x(1:3*N) )
  ALLOCATE( y(1:3*N) )

  x(:) = msg
  y(:) = msg

  x(N+1:2*N) = A(:)
  y(N+1:2*N) = B(:)

  y = EOSHIFT( y, SHIFT = -lag, BOUNDARY = msg )

  WHERE ( x == msg ) y = msg
  WHERE ( y == msg ) x = msg

  m = COUNT( x /= msg )

  IF ( m < 3 ) THEN

   WRITE (*,'(A40, I1)') "The number of overlapping points is m = ", m
   WRITE (*,'(A35)')     "The value of m should be 3 or more."
   WRITE (*,'(A17)')     "Decrease the lag."
   WRITE (*,'(A52)')     "Execution halted in SUBROUTINE UNBIASED_CORRELATION."
   STOP

  END IF

  xmn = SUM( x, DIM = 1, MASK = x /= msg ) / REAL(m)
  ymn = SUM( y, DIM = 1, MASK = y /= msg ) / REAL(m)

  ALLOCATE( xdev(1:3*N) )
  ALLOCATE( ydev(1:3*N) )

  xdev(:) = x(:) - xmn
  WHERE ( x == msg ) xdev(:) = msg

  ydev(:) = y(:) - ymn
  WHERE ( y == msg ) ydev(:) = msg

  ALLOCATE( xdevydev(1:3*N) )

  xdevydev(:) = xdev(:) * ydev(:)
  WHERE ( x == msg ) xdevydev(:) = msg

  COVxy = SUM( xdevydev, DIM = 1, MASK = xdevydev /= msg ) / REAL(m)

  ALLOCATE( xdevxdev(1:3*N) )

  xdevxdev(:) = xdev(:) * xdev(:)
  WHERE ( x == msg ) xdevxdev(:) = msg

  Sx = SQRT( SUM( xdevxdev, DIM = 1, MASK = xdevxdev /= msg ) / REAL(m) )

  ALLOCATE( ydevydev(1:3*N) )

  ydevydev(:) = ydev(:) * ydev(:)
  WHERE ( y == msg ) ydevydev(:) = msg

  Sy = SQRT( SUM( ydevydev, DIM = 1, MASK = ydevydev /= msg ) / REAL(m) )

  r = COVxy / ( Sx * Sy )

  IF ( r /= 1.0 ) THEN

    t = r * SQRT( (m - 2) / ( 1 - r*r ) )

  ELSE

    t = msg

  END IF

  DEALLOCATE( x, y, xdev, ydev, xdevydev, xdevxdev, ydevydev )

END SUBROUTINE UNBIASED_CORRELATION


!Calculates analytic vertical eddy diffusivity profiles
subroutine analytic_Kv(nlev, Ksurf, Km, Kbg, H, Kv)
use grid, only : Z_w
implicit none
integer, intent(in) :: nlev
real, intent(in)  :: Ksurf  ! Surface diffusivity
real, intent(in)  :: Km     ! maximal diffusivity
real, intent(in)  :: Kbg    ! Background diffusivity
real, intent(in)  :: H      ! MLD
real, intent(out) :: Kv(0:nlev)  ! Output Kv file

real :: z !Water depth

integer :: k

Kv(nlev) = Ksurf
do k = 1, nlev
   z = Z_w(k) !Current depth
   if (z .gt. -H/2.d0) then
      Kv(k)=Ksurf + (Km - Ksurf)*( 1.d0 - 1.5**(-abs(z)**2.3) )
   elseif (z .le. -H/2d0 .and. z .ge. -H) then
      Kv(k)=Kbg + (Km - Kbg)*( 1.d0 - 1.5**(-(H+z)**2.3) )
   else
      Kv(k)=Kbg
   endif
enddo
END subroutine analytic_Kv


subroutine eccf_decl(calday, daysperyear, delta, eccf)

! Computes declination angle (latitude of subsolar point) and
! eccentricity factor (which modulates insolation, accounting
! for deviation of Sun-planet distance from its mean along orbit)
! for a given calendar day and orbital parameters
! (accessed thru common/orbpar)

! Based on Pierrehumbert (2005), "A first course in climate"
! (http://geosci.uchicago.edu/~rtp1/geo232)

! Notes:
! - Following (obscure) convention, the precession angle mvelp
!   ("moving vernal equinox longitude of perihelion") is
!              mvelp = pi - kappa1e
!   where kappa1e is the angle from perihelion to vernal equinox
!
! - To match the calendar currently used on Earth, vernal equinox
!   is defined to occur 80/365 of the way through the year

! Rodrigo Caballero, University of Chicago, 2005.

implicit none

! In
real calday      ! calendar day
real daysperyear ! no. days in a year
real eccen, obliq, mvelp
common/orbpar/eccen, obliq, mvelp

! Out
real delta ! declination angle
real eccf  ! eccentricity factor

! Local
real kappa  ! season angle (0 at vernal equinox)
real kappa1 ! longitude of perihelion (angle from perihelion to sun-planet axis)
real pi
real, external :: season_angle

if (mvelp .eq. 0.) mvelp = 1.e-4
pi     = abs(acos(-1.))
kappa  = season_angle(calday, daysperyear)
kappa1 = pi - mvelp*pi/180. + kappa

delta = asin(sin(obliq*pi/180.)*sin(kappa))
eccf  = ( 1. + eccen*cos(kappa1) ) / (1. - eccen*eccen)
eccf  = eccf*eccf

end subroutine eccf_decl
!-------------------------------------------------------------------------
real function season_angle(calday, daysperyear)

! "Season angle" is defined as the angle from vernal equinox to
! position of sun-planet axis on day calday.

! Here, it is found by numerically inverting the relation between
! season angle and calendar time using Ridder's root-finding  algorithm.

! To match the calendar currently used on Earth, vernal equinox
! is defined to occur 80/365 of the way through the year

implicit none

! In
real calday       ! calendar day
real daysperyear  ! number of days in year
real eccen, obliq, mvelp
common/orbpar/eccen, obliq, mvelp

! Local
real period     ! adimensional period of orbit
real params(10) ! dummy vector to carray parameters
logical success
real pi
real, external :: ridder,diff,integral

pi = abs(acos(-1.))
period = integral(eccen,2.*pi)

params(1) = period
params(2) = calday/daysperyear  - 80./365.
season_angle = ridder(success, diff, params, -2.*pi, 2.*pi, .0001)

if (.not.success) then
print*,'damm'
stop
endif

end function season_angle
!------------------------------------------------------------------------
real function diff(params, kappa)

! Returns the difference between time taken to reach
! season angle kappa, and a specified target time

implicit none

! In
real kappa      ! season angle
real params(10) ! parameter vector
real eccen, obliq, mvelp
common/orbpar/eccen, obliq, mvelp

! Local
real period      ! orbital period
real time        ! time taken to reach season angle kappa
real target_time ! target time
real kappa1e     ! angle between perihelion and vernal equinox
real pi
real, external :: integral

pi          = abs(acos(-1.))
period      = params(1)
target_time = params(2)

kappa1e = pi - mvelp*pi/180.
time    = integral(eccen, kappa1e+kappa) - integral(eccen, kappa1e)

diff = time/period - target_time ! note time is adimensionalised by period

end function diff
!------------------------------------------------------------------------
real function integral(e,x)

! Returns indefinite integral of 1/(1+e*cos x)**2

implicit none
real e,x,oneme2,a,pi

oneme2   = 1.-e*e
a = atan( ((1.-e)/(1.+e))**0.5*tan(x/2.) )

pi = abs(acos(-1.))
if (x .gt.  pi)  a = a + pi
if (x .lt. -pi)  a = a - pi

integral = 2./oneme2**1.5*a - e*sin(x)/oneme2/(1.+e*cos(x))

end function integral
!------------------------------------------------------------------------
real function ridder(success, func, params, xmin, xmax, acc)

! Find zero crossing of func(x) in range xmin < x < xmax with accuracy acc
! Use Ridder's method (Numerical Recipes)

real params(10),xmin,xmax,acc,func
logical success
external func

maxit=60  ! max number of iterations
success=.true.

fl=func(params,xmin)
fh=func(params,xmax)

if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then
   xl=xmin
   xh=xmax
   ridder=-1.11e30
   do j=1,maxit
      xm=0.5*(xl+xh)
      fm=func(params,xm)
      s=sqrt(fm**2-fl*fh)
      if(s.eq.0.)return
      xnew=xm+(xm-xl)*(sign(1.,fl-fh)*fm/s)
      if (abs(xnew-ridder).le.acc) return
      ridder=xnew
      fnew=func(params,ridder)
      if (fnew.eq.0.) return
      if(sign(fm,fnew).ne.fm) then
         xl=xm
         fl=fm
         xh=ridder
         fh=fnew
      else if(sign(fl,fnew).ne.fl) then
         xh=ridder
         fh=fnew
      else if(sign(fh,fnew).ne.fh) then
         xl=ridder
         fl=fnew
      else
         stop 'never get here in ridder'
      endif
      if(abs(xh-xl).le.acc) return
   enddo
   stop 'ridder exceed maximum iterations maxit'
else if (fl.eq.0.) then
   ridder=xmin
else if (fh.eq.0.) then
   ridder=xmax
else
   success=.false.
endif

end function ridder


	Program pai
	Implicit none
	integer max
c declarations
	Real volume, x, y, z, area
	Integer i, pi3, pi2
	print*,'input the number for try'
	read(5,*) max
	pi3=0
c use max as random seed
	call srand(max)
c execute
	Do 10 i=1, max
c generate (x,y) within [-1,1]:
	   x = rand()*2-1
	   y = rand()*2-1
	   z = rand()*2-1
	   If ((x*x + y*y + z*z) .LE. 1) pi3 = pi3 + 1
	   volume = 6.0 * pi3/Real(i)
c volume inside sphere ~ pts/i = 4/3*pi*r**3 --> pi= pts*8
 	   if(mod(i,int(sqrt(i*1.0))).eq.1) Write(6,100) i, volume
 10 	Continue

        Write(6,100) max, volume
100	format(1x,'try= ',i10,2x,'pai=',f8.4)
c do-while loop to get enough significant numbers
	pi3=0
	i=0
	do while(abs(volume-3.1415927).GT.1E-4)
	   x = rand()*2-1
	   y = rand()*2-1
	   z = rand()*2-1
	   i = i+1
	   if ((x*x + y*y + z*z).LE.1) pi3 = pi3 +1
           volume = 6.0 * pi3/Real(i)
 	enddo
	write (6,200), i,volume
200	format(i8," trials are needed, the final value of Pi is ",f5.3)
	stop
	end