!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
module statistical
!===============================================================================
!  Contains statistical functions
!  Andy Nowacki, University of Bristol
!
!  2011-06-13   + First iteration.  Includes F-distribution, Beta- (B), regularized
!                 Beta- (I) and incomplete Beta-functions
!  2011-06-17   + Added functions from Alan Miller's website to compute percentage
!                 values for the chi2 distribution.
!  2011-08-09   + Added circular statistical functions.

!  Declare public functions
!   public f_dist

!  Declare some internal constants
!  ** size constants
      integer, parameter, private :: i4 = selected_int_kind(9) ; ! long int
      integer, parameter, private :: r4 = selected_real_kind(6,37) ; ! SP
      integer, parameter, private :: r8 = selected_real_kind(15,307) ; ! DP
      integer, parameter, private :: c4 = r4
      integer, parameter, private :: c8 = r8

!  ** precision selector
      integer, parameter, private :: rs = r8
      integer, parameter, private :: cs = c8

!  ** maths constants and other useful things
      real(rs), parameter, private :: pi = 3.141592653589793238462643_rs

!  ** IO units
      integer, parameter, private :: lu_stdout = 5
      integer, parameter, private :: lu_stdin  = 6
      integer, parameter, private :: lu_stderr = 0

contains

!===============================================================================
function fact12(n)
!===============================================================================
!  Gives true integer value for n!, n <= 12
   implicit none
   integer,intent(in) :: n
   integer            :: fact12,i

   if (n < 0) then
      write(lu_stderr,'(a)') 'statistical: fact: error: n must be >= 0.'
      stop
   else if (n == 0) then
      fact12 = 1
      return
   else if (n > 12) then
      write(lu_stderr,'(a)') 'statistical: fact: error: n cannot be larger than 12 for 4-byte integer calculations.'
      stop
   endif
   fact12 = 1
   do i=1,n
      fact12 = i*fact12
   enddo
   return
end function fact12
!-------------------------------------------------------------------------------

!===============================================================================
function fact(n)
!===============================================================================
!  Gives approximate value of n! up to n<170
!  fact(n) ≈ exp{n.ln(n) - n + ln(n(1 + 4n(1 + 2n)))/6 + ln(pi)/2}
!  Approximation given by Ramanujan (1988)
!  Good to within ~1e-5 of integer value up to n=12.
   implicit none
   integer,intent(in) :: n
   real(rs)           :: fact,rn

   if (n == 0) then
      fact = 1._rs
      return
   else if (n < 0) then
      write(lu_stderr,'(a)') 'statistical: fact: error: n must be >= 0.'
      stop
   else if (n > 0 .and. n <= 12) then
      fact = real(fact12(n))
      return
   else if (n > 170) then
      write(lu_stderr,'(a)') 'statistical: fact: error: cannot represent n! in double precision for n > 170.'
      stop
   endif

   rn = real(n)
   fact = exp(n*log(rn) - rn + log(rn*(1._rs + 4._rs*rn*(1._rs + 2._rs*rn)))/6._rs &
                                                         + log(pi)/2._rs)
   return
end function fact
!-------------------------------------------------------------------------------

!===============================================================================
function stat_poisson_pmf(lambda, k)
!===============================================================================
! Return the probability mass function for the Poisson distribution with mean
! lambda at integer point k
   implicit none
   real(rs), intent(in) :: lambda
   integer, intent(in) :: k
   real(rs) :: stat_poisson_pmf
   stat_poisson_pmf = lambda**k*exp(-lambda)/fact(k)
end function stat_poisson_pmf
!-------------------------------------------------------------------------------

!===============================================================================
function beta_func(p,q)
!===============================================================================
!  Returns the Beta function B(p,q) = Gamma(p)*Gamma(q) / Gamma(p+q)
   implicit none
   real(rs),intent(in) :: p,q
   real(rs)            :: beta_func,rp,rq

   rp = real(p)  ;  rq = real(q)
   beta_func = gamma(rp) * gamma(rq) / gamma(rp + rq)
   return
end function beta_func
!-------------------------------------------------------------------------------

!===============================================================================
function incomp_beta_func(z,a,b)
!===============================================================================
!  Returns the incomplete Beta function B(z;a,b) = ∫_0^z(u^(a-1)*(1-u)^(b-1))du
   implicit none
   real(rs),intent(in) :: z,a,b
   real(rs)            :: incomp_beta_func,ra,rb,rn
   real(rs)            :: u,du   ! Dummy variable of integration
   integer             :: n

   ra = real(a)
   rb = real(b)
   if (z <= 0. .or. z > 1.) then
      write(lu_stderr,'(a)') 'statistical: incomp_beta_func: error: z must be in range [0,1].'
      stop
   endif
   du = 0.000001_rs
   u = 0._rs
   incomp_beta_func = 0._rs
   do while (u <= z)
      incomp_beta_func = incomp_beta_func + (u**(a-1._rs))*((1._rs-u)**(b-1._rs))*du
      u = u + du
   enddo
   incomp_beta_func = incomp_beta_func / beta_func(a,b)
   return
end function incomp_beta_func
!-------------------------------------------------------------------------------

!===============================================================================
function reg_beta_func(z,a,b)
!===============================================================================
!  Returns the regularised Beta function B(a,b) = B(z;a,b)/B(a,b)
   implicit none
   real(rs),intent(in) :: z,a,b
   real(rs)            :: reg_beta_func

   reg_beta_func = incomp_beta_func(z,a,b) / beta_func(a,b)
   return
end function reg_beta_func
!-------------------------------------------------------------------------------

!===============================================================================
function pochhammer(x,n)
!===============================================================================
!  Give the Pochhhammer symbol p(x)_n == gamma(x+n)/gamma(x)
   implicit none
   real(rs),intent(in) :: x
   integer,intent(in)  :: n
   real(rs)            :: pochhammer,rn

   rn = real(n)
   pochhammer = gamma(x+rn)/gamma(x)
   return
end function pochhammer
!-------------------------------------------------------------------------------

!===============================================================================
function f_dist(n,m,x)
!===============================================================================
!  Returns the value of the f distribution f(n,m,x)
   implicit none
   integer             :: m,n
   real(rs)            :: x
   real(rs)            :: f_dist
   real(rs)            :: rn,rm,half,one

   if (x <= 0.) then
      write(lu_stderr,'(a)') 'statistical: f_dist: error: x must be > 0.'
      stop
   endif

!  Convert input integers into real values and set value of half
   rn = real(n)
   rm = real(m)
   half = 0.5_rs
   one = 1.0_rs

   f_dist = gamma(half*(rn+rm)) * rn**(half*rn) * rm**(half*rm) * x**(half*rn - one) / &
            (gamma(half*rn) * gamma(half*rm) * (rm+rn*x)**(half*(rn + rm)))
   return
end function f_dist
!-------------------------------------------------------------------------------

!===============================================================================
function f_dist_cum(n,m,x)
!===============================================================================
!  Returns the value of the cumulative F distribution F(n,m,x)
   implicit none
   integer,intent(in)  :: m,n
   real(rs),intent(in) :: x
   real(rs)            :: f_dist_cum,u,du
   real(rs)            :: rm,rn
!  Convert input integers into real values
   rm = real(m)
   rn = real(n)

!   f_dist_cum = reg_beta_func(rn*x/(rm+rn*x), rn*0.5_rs, rm*0.5_rs)
   f_dist_cum = 0._rs
   du = 0.0001_rs
   u = 0._rs + du
   do while (u <= x)
      f_dist_cum = f_dist_cum + f_dist(n,m,u)*du
      u = u + du
   enddo
   return
end function f_dist_cum
!-------------------------------------------------------------------------------

!===============================================================================
!===============================================================================
! The following functions are taken from Alan Miller's page at:
! http://jblevins.org/mirror/amiller/
! All are transcriptions into Fortran of algorithms plublished in the Royal Statistical
! Society's Applied Statitstics journal.

!===============================================================================
function ppchi2(p, v, g) RESULT(fn_val)
!===============================================================================
! N.B. Argument IFAULT has been removed.
! This version by Alan Miller
! amiller @ bigpond.net.au
! Latest revision - 27 October 2000
!  Algorithm AS 91   Appl. Statist. (1975) Vol.24, P.35
!
!  To evaluate the percentage points of the chi-squared
!  probability distribution function.
!
!  p must lie in the range 0.000002 to 0.999998,
!  v must be positive,
!  g must be supplied and should be equal to ln(gamma(v/2.0))
!
!  Incorporates the suggested changes in AS R85 (vol.40(1), pp.233-5, 1991)
!  which should eliminate the need for the limited range for p above,
!  though these limits have not been removed from the routine.
!
!  If IFAULT = 4 is returned, the result is probably as accurate as
!  the machine will allow.
!
!  Auxiliary routines required: PPND = AS 111 (or AS 241) and GAMMAD = AS 239.

   IMPLICIT NONE
   INTEGER, PARAMETER    :: dp = rs

   REAL (dp), INTENT(IN)  :: p
   REAL (dp), INTENT(IN)  :: v
   REAL (dp), INTENT(IN)  :: g
   REAL (dp)              :: fn_val

! AJN: don't need interface as we're in a module.
!   INTERFACE
!     FUNCTION gammad(x, p) RESULT(fn_val)
!       IMPLICIT NONE
!       INTEGER, PARAMETER    :: dp = rs
!       REAL (dp), INTENT(IN) :: x, p
!       REAL (dp)             :: fn_val
!     END FUNCTION gammad
!
!     SUBROUTINE ppnd16 (p, normal_dev, ifault)
!       IMPLICIT NONE
!       INTEGER, PARAMETER      :: dp = rs
!       REAL (dp), INTENT(IN)   :: p
!       INTEGER, INTENT(OUT)    :: ifault
!       REAL (dp), INTENT(OUT)  :: normal_dev
!     END SUBROUTINE ppnd16
!   END INTERFACE

! Local variables

   REAL (dp)  :: a, b, c, p1, p2, q, s1, s2, s3, s4, s5, s6, t, x, xx
   INTEGER    :: i, if1

   INTEGER, PARAMETER    :: maxit = 20
   REAL (dp), PARAMETER  :: aa = 0.6931471806_dp, e = 0.5e-06_dp,         &
                            pmin = 0.000002_dp, pmax = 0.999998_dp,       &
                            zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp,   &
                            two = 2.0_dp, three = 3.0_dp, six = 6.0_dp,   &
                            c1 = 0.01_dp, c2 = 0.222222_dp, c3 = 0.32_dp, &
                            c4 = 0.4_dp, c5 = 1.24_dp, c6 = 2.2_dp,       &
                            c7 = 4.67_dp, c8 = 6.66_dp, c9 = 6.73_dp,     &
                            c10 = 13.32_dp, c11 = 60.0_dp, c12 = 70.0_dp, &
                            c13 = 84.0_dp, c14 = 105.0_dp, c15 = 120.0_dp, &
                            c16 = 127.0_dp, c17 = 140.0_dp, c18 = 175.0_dp, &
                            c19 = 210.0_dp, c20 = 252.0_dp, c21 = 264.0_dp, &
                            c22 = 294.0_dp, c23 = 346.0_dp, c24 = 420.0_dp, &
                            c25 = 462.0_dp, c26 = 606.0_dp, c27 = 672.0_dp, &
                            c28 = 707.0_dp, c29 = 735.0_dp, c30 = 889.0_dp, &
                            c31 = 932.0_dp, c32 = 966.0_dp, c33 = 1141.0_dp, &
                            c34 = 1182.0_dp, c35 = 1278.0_dp, c36 = 1740.0_dp, &
                            c37 = 2520.0_dp, c38 = 5040.0_dp

!  Test arguments and initialise
   fn_val = -one
   IF (p < pmin .OR. p > pmax) THEN
      WRITE(lu_stderr,'(a)') 'statistical: PPCHI2: error: p must be between 0.000002 & 0.999998'
      stop !RETURN
   END IF
   IF (v <= zero) THEN
      WRITE(lu_stderr,'(a)') 'statistical: PPCHI2: error: Number of deg. of freedom <= 0'
      stop !RETURN
   END IF

   xx = half * v
   c = xx - one

!  Starting approximation for small chi-squared
   IF (v < -c5 * LOG(p)) THEN
      fn_val = (p * xx * EXP(g + xx * aa)) ** (one/xx)
      IF (fn_val < e) GO TO 6
      GO TO 4
   END IF

!  Starting approximation for v less than or equal to 0.32
   IF (v > c3) GO TO 3
   fn_val = c4
   a = LOG(one-p)

   2 q = fn_val
   p1 = one + fn_val * (c7+fn_val)
   p2 = fn_val * (c9 + fn_val * (c8 + fn_val))
   t = -half + (c7 + two * fn_val) / p1 - (c9 + fn_val * (c10 + three * fn_val)) / p2
   fn_val = fn_val - (one - EXP(a + g + half * fn_val + c * aa) * p2 / p1) / t
   IF (ABS(q / fn_val - one) > c1) GO TO 2
   GO TO 4

!  Call to algorithm AS 241 - note that p has been tested above.
   3 CALL ppnd16(p, x, if1)

!  Starting approximation using Wilson and Hilferty estimate
   p1 = c2 / v
   fn_val = v * (x * SQRT(p1) + one - p1) ** 3

!  Starting approximation for p tending to 1
   IF (fn_val > c6 * v + six) fn_val = -two * (LOG(one-p) - c * LOG(half * fn_val) + g)

!  Call to algorithm AS 239 and calculation of seven term Taylor series
   4 DO i = 1, maxit
      q = fn_val
      p1 = half * fn_val
      p2 = p - gammad(p1, xx)

      t = p2 * EXP(xx * aa + g + p1 - c * LOG(fn_val))
      b = t / fn_val
      a = half * t - b * c
      s1 = (c19 + a * (c17 + a * (c14 + a * (c13 + a * (c12 + c11 * a))))) / c24
      s2 = (c24 + a * (c29 + a * (c32 + a * (c33 + c35 * a)))) / c37
      s3 = (c19 + a * (c25 + a * (c28 + c31 * a))) / c37
      s4 = (c20 + a * (c27 + c34 * a) + c * (c22 + a * (c30 + c36 * a))) / c38
      s5 = (c13 + c21 * a + c * (c18 + c26 * a)) / c37
      s6 = (c15 + c * (c23 + c16 * c)) / c38
      fn_val = fn_val + t * (one + half * t * s1 - b * c * (s1 - b *   &
               (s2 - b * (s3 - b * (s4 - b * (s5 - b * s6))))))
      IF (ABS(q / fn_val - one) > e) RETURN
   END DO

   WRITE(lu_stderr,'(a)') 'statistical: PPCHI2: error: Max. number of iterations exceeded'
   stop

   6 RETURN
END FUNCTION ppchi2
!-------------------------------------------------------------------------------

!===============================================================================
function gammad(x, p) RESULT(fn_val)
!===============================================================================
!  ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3

!  Computation of the Incomplete Gamma Integral

!  Auxiliary functions required: ALOGAM = logarithm of the gamma
!  function, and ALNORM = algorithm AS66

! ELF90-compatible version by Alan Miller
! Latest revision - 27 October 2000

! N.B. Argument IFAULT has been removed
! AJN: Remove need for alogam by using log_gamma, intrinsic in Fortran 2008 and
!      implemented in most recent compilers.

   IMPLICIT NONE
   INTEGER, PARAMETER    :: dp = rs
   REAL (dp), INTENT(IN) :: x, p
   REAL (dp)             :: fn_val

   ! Local variables
   REAL (dp)             :: pn1, pn2, pn3, pn4, pn5, pn6, arg, c, rn, a, b, an
   REAL (dp), PARAMETER  :: zero = 0.d0, one = 1.d0, two = 2.d0, &
                            oflo = 1.d+37, three = 3.d0, nine = 9.d0, &
                            tol = 1.d-14, xbig = 1.d+8, plimit = 1000.d0, &
                            elimit = -88.d0
! EXTERNAL alogam, alnorm

   fn_val = zero

!  Check that we have valid values for X and P
   IF (p <= zero .OR. x < zero) THEN
     WRITE(lu_stderr,'(a)') 'statistical: gammad(AS239): error: Either p <= 0 or x < 0'
     stop !RETURN
   END IF
   IF (x == zero) RETURN

!  Use a normal approximation if P > PLIMIT
   IF (p > plimit) THEN
     pn1 = three * SQRT(p) * ((x / p) ** (one / three) + one /(nine * p) - one)
     fn_val = alnorm(pn1, .false.)
     RETURN
   END IF

!  If X is extremely large compared to P then set fn_val = 1
   IF (x > xbig) THEN
     fn_val = one
     RETURN
   END IF

   IF (x <= one .OR. x < p) THEN

!  Use Pearson's series expansion.
!  (Note that P is not large enough to force overflow in ALOGAM).
!  No need to test IFAULT on exit since P > 0.
!     arg = p * LOG(x) - x - alogam(p + one, ifault)
     arg = p * LOG(x) - x - log_gamma(p + one)
     c = one
     fn_val = one
     a = p
     40   a = a + one
     c = c * x / a
     fn_val = fn_val + c
     IF (c > tol) GO TO 40
     arg = arg + LOG(fn_val)
     fn_val = zero
     IF (arg >= elimit) fn_val = EXP(arg)

   ELSE

!  Use a continued fraction expansion
!     arg = p * LOG(x) - x - alogam(p, ifault)
     arg = p * LOG(x) - x - log_gamma(p)
     a = one - p
     b = a + x + one
     c = zero
     pn1 = one
     pn2 = x
     pn3 = x + one
     pn4 = x * b
     fn_val = pn3 / pn4
     60   a = a + one
     b = b + two
     c = c + one
     an = a * c
     pn5 = b * pn3 - an * pn1
     pn6 = b * pn4 - an * pn2
     IF (ABS(pn6) > zero) THEN
       rn = pn5 / pn6
       IF (ABS(fn_val - rn) <= MIN(tol, tol * rn)) GO TO 80
       fn_val = rn
     END IF

     pn1 = pn3
     pn2 = pn4
     pn3 = pn5
     pn4 = pn6
     IF (ABS(pn5) >= oflo) THEN

!  Re-scale terms in continued fraction if terms are large
       pn1 = pn1 / oflo
       pn2 = pn2 / oflo
       pn3 = pn3 / oflo
       pn4 = pn4 / oflo
     END IF
     GO TO 60
     80   arg = arg + LOG(fn_val)
     fn_val = one
     IF (arg >= elimit) fn_val = one - EXP(arg)
   END IF

   RETURN
END FUNCTION gammad
!-------------------------------------------------------------------------------

!===============================================================================
subroutine ppnd16 (p, normal_dev, ifault)
!===============================================================================
! ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3

! Produces the normal deviate Z corresponding to a given lower
! tail area of P; Z is accurate to about 1 part in 10**16.

! The hash sums below are the sums of the mantissas of the
! coefficients.   They are included for use in checking
! transcription.

! This ELF90-compatible version by Alan Miller - 20 August 1996
! N.B. The original algorithm is as a function; this is a subroutine

   IMPLICIT NONE

   INTEGER, PARAMETER      :: dp = rs
   REAL (dp), INTENT(IN)   :: p
   INTEGER, INTENT(OUT)    :: ifault
   REAL (dp), INTENT(OUT)  :: normal_dev

! Local variables
   REAL (dp) :: zero = 0.d0, one = 1.d0, half = 0.5d0,  &
                split1 = 0.425d0, split2 = 5.d0, const1 = 0.180625d0, &
                const2 = 1.6d0, q, r

! Coefficients for P close to 0.5
   REAL (dp) :: a0 = 3.3871328727963666080D0, &
                a1 = 1.3314166789178437745D+2, &
                a2 = 1.9715909503065514427D+3, &
                a3 = 1.3731693765509461125D+4, &
                a4 = 4.5921953931549871457D+4, &
                a5 = 6.7265770927008700853D+4, &
                a6 = 3.3430575583588128105D+4, &
                a7 = 2.5090809287301226727D+3, &
                b1 = 4.2313330701600911252D+1, &
                b2 = 6.8718700749205790830D+2, &
                b3 = 5.3941960214247511077D+3, &
                b4 = 2.1213794301586595867D+4, &
                b5 = 3.9307895800092710610D+4, &
                b6 = 2.8729085735721942674D+4, &
                b7 = 5.2264952788528545610D+3
! HASH SUM AB    55.8831928806149014439

! Coefficients for P not close to 0, 0.5 or 1.
   REAL (dp) :: c0 = 1.42343711074968357734D0, &
                c1 = 4.63033784615654529590D0, &
                c2 = 5.76949722146069140550D0, &
                c3 = 3.64784832476320460504D0, &
                c4 = 1.27045825245236838258D0, &
                c5 = 2.41780725177450611770D-1, &
                c6 = 2.27238449892691845833D-2, &
                c7 = 7.74545014278341407640D-4, &
                d1 = 2.05319162663775882187D0, &
                d2 = 1.67638483018380384940D0, &
                d3 = 6.89767334985100004550D-1, &
                d4 = 1.48103976427480074590D-1, &
                d5 = 1.51986665636164571966D-2, &
                d6 = 5.47593808499534494600D-4, &
                d7 = 1.05075007164441684324D-9
! HASH SUM CD    49.33206503301610289036

! Coefficients for P near 0 or 1.
   REAL (dp) :: e0 = 6.65790464350110377720D0, &
                e1 = 5.46378491116411436990D0, &
                e2 = 1.78482653991729133580D0, &
                e3 = 2.96560571828504891230D-1, &
                e4 = 2.65321895265761230930D-2, &
                e5 = 1.24266094738807843860D-3, &
                e6 = 2.71155556874348757815D-5, &
                e7 = 2.01033439929228813265D-7, &
                f1 = 5.99832206555887937690D-1, &
                f2 = 1.36929880922735805310D-1, &
                f3 = 1.48753612908506148525D-2, &
                f4 = 7.86869131145613259100D-4, &
                f5 = 1.84631831751005468180D-5, &
                f6 = 1.42151175831644588870D-7, &
                f7 = 2.04426310338993978564D-15
! HASH SUM EF    47.52583317549289671629

   ifault = 0
   q = p - half
   IF (ABS(q) <= split1) THEN
      r = const1 - q * q
      normal_dev = q * (((((((a7*r + a6)*r + a5)*r + a4)*r + a3)*r + a2)*r + a1)*r + a0) / &
               (((((((b7*r + b6)*r + b5)*r + b4)*r + b3)*r + b2)*r + b1)*r + one)
      RETURN
   ELSE
      IF (q < zero) THEN
         r = p
      ELSE
         r = one - p
      END IF
      IF (r <= zero) THEN
         ifault = 1
         normal_dev = zero
         RETURN
      END IF
      r = SQRT(-LOG(r))
      IF (r <= split2) THEN
         r = r - const2
         normal_dev = (((((((c7*r + c6)*r + c5)*r + c4)*r + c3)*r + c2)*r + c1)*r + c0) / &
                  (((((((d7*r + d6)*r + d5)*r + d4)*r + d3)*r + d2)*r + d1)*r + one)
      ELSE
         r = r - split2
         normal_dev = (((((((e7*r + e6)*r + e5)*r + e4)*r + e3)*r + e2)*r + e1)*r + e0) / &
                  (((((((f7*r + f6)*r + f5)*r + f4)*r + f3)*r + f2)*r + f1)*r + one)
      END IF
      IF (q < zero) normal_dev = - normal_dev
      RETURN
   END IF
END SUBROUTINE ppnd16
!-------------------------------------------------------------------------------

!===============================================================================
function alnorm( x, upper ) RESULT( fn_val )
!===============================================================================
!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 2001

   IMPLICIT NONE
   INTEGER, PARAMETER     ::  dp = rs
   REAL(DP), INTENT(IN)   ::  x
   LOGICAL,   INTENT(IN)  ::  upper
   REAL(DP)               ::  fn_val

!  Local variables
   REAL(DP), PARAMETER   ::  zero=0.0_DP, one=1.0_DP, half=0.5_DP, con=1.28_DP
   REAL(DP)              ::  z, y
   LOGICAL               ::  up

!  Machine dependent constants
   REAL(DP), PARAMETER  ::  ltone = 7.0_DP, utzero = 18.66_DP
   REAL(DP), PARAMETER  ::  p = 0.398942280444_DP, q = 0.39990348504_DP,   &
                            r = 0.398942280385_DP, a1 = 5.75885480458_DP,  &
                            a2 = 2.62433121679_DP, a3 = 5.92885724438_DP,  &
                            b1 = -29.8213557807_DP, b2 = 48.6959930692_DP, &
                            c1 = -3.8052E-8_DP, c2 = 3.98064794E-4_DP,     &
                            c3 = -0.151679116635_DP, c4 = 4.8385912808_DP, &
                            c5 = 0.742380924027_DP, c6 = 3.99019417011_DP, &
                            d1 = 1.00000615302_DP, d2 = 1.98615381364_DP,  &
                            d3 = 5.29330324926_DP, d4 = -15.1508972451_DP, &
                            d5 = 30.789933034_DP

   up = upper
   z = x
   IF( z < zero ) THEN
      up = .NOT. up
      z = -z
   END IF
   IF( z <= ltone  .OR.  (up  .AND.  z <= utzero) ) THEN
      y = half*z*z
      IF( z > con ) THEN
         fn_val = r*EXP( -y )/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
      ELSE
         fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      END IF
   ELSE
      fn_val = zero
   END IF

   IF( .NOT. up ) fn_val = one - fn_val
   RETURN
END FUNCTION alnorm
!-------------------------------------------------------------------------------

!===============================================================================
!-------------------------------------------------------------------------------
!  Circular statistical functions
!-------------------------------------------------------------------------------
!===============================================================================

!===============================================================================
function circ_mean(angle,degrees)
!===============================================================================
!  Returns the circular mean of a set of angles.  Input is a column vector
!  of arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   real(rs)            :: circ_mean
   logical,intent(in),optional :: degrees
   logical                     :: radians

   radians = .false.
   if (present(degrees)) radians = .not.degrees

   if (radians) then
      circ_mean = atan2(sum( sin( angle(1:size(angle)) ) ), &
                        sum( cos( angle(1:size(angle)) ) ) )
   else
      circ_mean = atan2(sum( sin( angle(1:size(angle))*pi/180._rs ) ),  &
                        sum( cos( angle(1:size(angle))*pi/180._rs ) ) )
      circ_mean = circ_mean*180._rs/pi
   endif

   return
end function circ_mean
!-------------------------------------------------------------------------------

!===============================================================================
subroutine circ_mean_bootstrap(angle,mu,mu1,mu2,B,degrees)
!===============================================================================
!  Calculate a sample mean using a bootstrap technique.  Assumes a symmetric
!  distribution.  See Fisher, Statistical analysis of circular data, §4.4
!  Optionally specify number of bootstrap samples to take.
   implicit none
   real(rs),intent(in)  :: angle(:)
   real(rs),intent(out) :: mu
   real(rs),intent(out),optional :: mu1,mu2
   integer,intent(in),optional   :: B
   logical,intent(in),optional   :: degrees
   logical :: degrees_in

   degrees_in = .true.
   if (present(degrees)) degrees_in = degrees

   if (size(angle) <= 9) then  ! For small N, calculate all n**n samples
      call circ_mean_bootstrap_smallN(angle,mu,mu1,mu2,degrees=degrees_in)
   else
      write(lu_stderr,'(a)') 'statistical: circ_mean_bootstrap: only implemented for n<=9 at the moment.'
      stop
   endif

   return
end subroutine circ_mean_bootstrap
!-------------------------------------------------------------------------------

!===============================================================================
subroutine circ_mean_bootstrap_smallN(angle,mu,mu1,mu2,degrees,force)
!===============================================================================
!  For a small sample, calculate the bootstrap mean and confidence interval
!  by taking all possible subsamples of the data (= n**n).
!  If n==9, then n**n real*4s takes up ~1.5 GB.  Use this routine with care on
!  lesser or shared machines!  Hence a warning is displayed, unless the force=.true.
!  option is employed on the command line.
   implicit none
   real(rs),intent(in)  :: angle(:)
   real(rs),intent(out) :: mu,mu1,mu2
   logical,intent(in),optional :: degrees,force
   logical :: force_in
   real(rs) :: conversion
   real(r4) :: Csum,Ssum
   real(r4),allocatable :: mean(:)  ! Use single preision for storage of bootstrap samples
   real(rs),allocatable :: rangle(:)
   integer :: n,i,i1,i2,i3,i4,i5,i6,i7,i8,i9

!  We're potentially allocating <=1.5 GB of memory, so make sure we know what
!  we're doing.
   force_in = .false.
   if (present(force)) force_in = force
   if (.not.force_in) then
      if (size(angle) >= 8) then
         write(*,'(a,f0.0,a)') 'circ_mean_bootstrap_smallN is about to allocate ',&
                  8.*size(angle)**size(angle)/(1024.**2),' MB of memory.'
         write(*,'(a)') 'Hit return to continue, or ^C to abort.'
         read(*,*)
      endif
   endif

!  Check we're only testing with small sample size
   n = size(angle)
   if (n > 9 .or. n == 1) then
      write(lu_stderr,'(a)') &
      'statistical: circ_mean_bootstrap_smallN: number of samples too large for small N subroutine, or n is 1.'
      stop
   endif

!  Allocate memory for all n**n sample means: here we go!
   allocate(mean(n**n))

!  Convert angles into radians if necesary
   allocate(rangle(n))
   conversion = pi/180._rs
   if (present(degrees)) then
      if (.not.degrees) conversion = 1._rs
   endif
   rangle = conversion*angle

!  Calculate sample mean for all possible bootstrap samples
   i = 1
   if (n == 2) then
      do i1=1,n
       do i2=1,n
               Csum = cos(rangle(i1)) + cos(rangle(i2))
               Ssum = sin(rangle(i1)) + sin(rangle(i2))
               mean(i) = atan2(Ssum,Csum)
               i = i + 1
       enddo
      enddo

   else if (n == 3) then
      do i1=1,n
       do i2=1,n
        do i3=1,n
               Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3))
               Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3))
               mean(i) = atan2(Ssum,Csum)
               i = i + 1
        enddo
       enddo
      enddo

   else if (n == 4) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 8 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
         enddo
        enddo
       enddo
      enddo

   else if (n == 5) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 8 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
          do i5=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4)) + cos(rangle(i5))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4)) + sin(rangle(i5))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
          enddo
         enddo
        enddo
       enddo
      enddo

   else if (n == 6) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 8 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
          do i5=1,n
           do i6=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4)) + cos(rangle(i5)) + cos(rangle(i6))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4)) + sin(rangle(i5)) + sin(rangle(i6))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo

   else if (n == 7) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 8 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
          do i5=1,n
           do i6=1,n
            do i7=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4)) + cos(rangle(i5)) + cos(rangle(i6)) + &
                        cos(rangle(i7))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4)) + sin(rangle(i5)) + sin(rangle(i6)) + &
                        sin(rangle(i7))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
            enddo
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo

   else if (n == 8) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 8 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
          do i5=1,n
           do i6=1,n
            do i7=1,n
             do i8=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4)) + cos(rangle(i5)) + cos(rangle(i6)) + &
                        cos(rangle(i7)) + cos(rangle(i8))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4)) + sin(rangle(i5)) + sin(rangle(i6)) + &
                        sin(rangle(i7)) + sin(rangle(i8))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
             enddo
            enddo
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo

   else if (n == 9) then
      do i1=1,n
       write(*,'(a,i0,a)') 'Executing ',i1,' of 9 passes.'
       do i2=1,n
        do i3=1,n
         do i4=1,n
          do i5=1,n
           do i6=1,n
            do i7=1,n
             do i8=1,n
              do i9=1,n
                 Csum = cos(rangle(i1)) + cos(rangle(i2)) + cos(rangle(i3)) + &
                        cos(rangle(i4)) + cos(rangle(i5)) + cos(rangle(i6)) + &
                        cos(rangle(i7)) + cos(rangle(i8)) + cos(rangle(i9))
                 Ssum = sin(rangle(i1)) + sin(rangle(i2)) + sin(rangle(i3)) + &
                        sin(rangle(i4)) + sin(rangle(i5)) + sin(rangle(i6)) + &
                        sin(rangle(i7)) + sin(rangle(i8)) + sin(rangle(i9))
                 mean(i) = atan2(Ssum,Csum)
                 i = i + 1
              enddo
             enddo
            enddo
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
   endif

   mu = sum(mean)/(conversion*n**n)

   return
end subroutine circ_mean_bootstrap_smallN
!-------------------------------------------------------------------------------

!===============================================================================
function circ_res_length(angle,degrees)
!===============================================================================
!  Returns the resultant length of the angles.  Input is a column vector of
!  arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   real(rs)            :: circ_res_length
   logical,intent(in),optional :: degrees
   logical                     :: radians

   radians = .false.
   if (present(degrees)) radians = .not.degrees

   if (radians) then
      circ_res_length = sqrt((sum(sin(angle(1:size(angle)))))**2 + &
                             (sum(cos(angle(1:size(angle)))))**2) / real(size(angle))
   else
      circ_res_length = sqrt((sum( sin(angle(1:size(angle))*pi/180._rs)) )**2 + &
                (sum( cos(angle(1:size(angle))*pi/180._rs)) )**2) / real(size(angle))
   endif

   return
end function circ_res_length
!-------------------------------------------------------------------------------

!===============================================================================
function circ_sd(angle,degrees)
!===============================================================================
!  Returns the circular standard deviation.  Input is a column vector of
!  arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   real(rs)            :: circ_sd
   logical,intent(in),optional :: degrees
   logical                     :: degrees_in

   degrees_in = .true.
   if (present(degrees)) degrees_in = degrees

   circ_sd = sqrt(-2._rs*log(circ_res_length(angle,degrees=degrees_in)))

   return
end function circ_sd
!===============================================================================

!===============================================================================
function circ_variance(angle,degrees)
!===============================================================================
!  Returns the circular variance of a set of angles.  Input is a column vector
!  of arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   real(rs)            :: circ_variance,mean
   logical,intent(in),optional :: degrees
   logical                     :: radians

   radians = .false.
   if (present(degrees)) radians = .not.degrees

   if (radians) then
      mean = circ_mean(angle,degrees=.false.)
      circ_variance = 1._rs - sum(cos(angle - mean))/real(size(angle))
   else
      mean = circ_mean(angle,degrees=.true.) * pi/180._rs
      circ_variance = 1._rs - sum(cos(angle*pi/180._rs - mean))/real(size(angle))
   endif

   return
end function circ_variance
!-------------------------------------------------------------------------------

!===============================================================================
function circ_uncent_trig_moment(angle,p,degrees)
!===============================================================================
!  Returns the uncentered pth trigonometric moment.  Input is a column vector of
!  arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   integer,intent(in)  :: p
   complex(cs)         :: circ_uncent_trig_moment
   real(rs) :: Cp,Sp
   integer  :: n
   logical,intent(in),optional :: degrees
   real(rs) :: conversion

!  Check for valid p
   if (p < 1) then
      write(lu_stderr,'(a)') 'statistical: circ_uncent_trig_moment: p must be > 0.'
      stop
   endif

!  Convert from degrees to radians unless otherwise
   conversion = pi/180._rs
   if (present(degrees)) then
      if (.not.degrees) conversion = 1._rs
   endif

   n = size(angle)
   Cp = sum(cos(real(p)*angle(1:n)*conversion))/real(n)
   Sp = sum(sin(real(p)*angle(1:n)*conversion))/real(n)

   circ_uncent_trig_moment = cmplx(Cp, Sp)

   return
end function circ_uncent_trig_moment
!-------------------------------------------------------------------------------

!===============================================================================
function circ_cent_trig_moment(angle,p,degrees)
!===============================================================================
!  Returns the centered pth trigonometric moment.  Input is a column vector of
!  arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   integer, intent(in) :: p
   complex(cs)         :: circ_cent_trig_moment
   real(rs) :: Cp,Sp,mean,conversion
   integer  :: n
   logical,intent(in),optional :: degrees

!  Check for valid p
   if (p < 1) then
      write(lu_stderr,'(a)') 'statistical: circ_cent_trig_moment: P must be > 0.'
      stop
   endif

!  Convert from degrees to radians unless otherwise desired
   conversion = pi/180._rs
   if (present(degrees)) then;  if (.not.degrees) conversion = 1._rs; endif

   n = size(angle)
   mean = circ_mean(angle,degrees=degrees)
   Cp = sum(cos(real(p)*conversion*(angle(1:n) - mean)))/real(n)
   Sp = sum(sin(real(p)*conversion*(angle(1:n) - mean)))/real(n)

   circ_cent_trig_moment = cmplx(Cp, Sp)

   return
end function circ_cent_trig_moment
!-------------------------------------------------------------------------------

!===============================================================================
function circ_dispers(angle,degrees)
!===============================================================================
!  Returns the circular dispersion of a set of angles.  Input is a column vector
!  of arbitrary length.  Default is for input in degrees.
   implicit none
   real(rs),intent(in) :: angle(:)
   real(rs)            :: circ_dispers
   real(rs) :: mean,rho2,R,conversion
   integer :: n
   logical,intent(in),optional :: degrees

!  By default, convert from degrees to radians for calculations
   conversion = pi/180._rs
   if (present(degrees)) then
      if (.not.degrees) conversion = 1._rs
   endif

   mean = circ_mean(angle,degrees=degrees)
   n = size(angle)
   R = sum(cos(conversion*(angle(1:n) - mean)))/real(n)
   rho2 = sum(cos(2._rs*conversion*(angle(1:n) - mean)))/real(n)
   circ_dispers = (1._rs - rho2)/(2._rs*R**2)

   return
end function circ_dispers
!-------------------------------------------------------------------------------

!===============================================================================
function circ_correl(a,b,degrees)
!===============================================================================
!  Returns the circular correlation between two sets of angles.  Input is two
!  column vectors of arbitrary (but the same) length.  Default is for input
!  in dgerees.
   implicit none
   real(rs),intent(in) :: a(:), b(:)
   real(rs)            :: circ_correl, amean, bmean
   logical,intent(in),optional :: degrees
   logical                     :: radians

!  Check arrays are same length
   if (size(a) /= size(b)) then
      write(0,'(a)') 'Error: statistical: circ_correl: Input arrays are not same length.'
      stop
   endif

   radians = .false.
   if (present(degrees)) radians = .not.degrees

   if (radians) then
      amean = circ_mean(a,degrees=.false.)
      bmean = circ_mean(a,degrees=.false.)
      circ_correl = sum( sin(a - amean) * sin(b - bmean) )/ &
            sqrt( sum( sin(a-amean)*sin(a-amean)*sin(b-bmean)*sin(b-bmean) ) )
   else
      amean = circ_mean(a,degrees=.true.) * pi/180._rs
      bmean = circ_mean(b,degrees=.true.) * pi/180._rs
      circ_correl = sum( sin(a*pi/180._rs - amean) * sin(b*pi/180._rs - bmean) )/ &
            sqrt( sum( sin(a*pi/180._rs-amean)*sin(a*pi/180._rs-amean) * &
                  sin(b*pi/180._rs-bmean)*sin(b*pi/180._rs-bmean) ) )
   endif

   return
end function circ_correl
!-------------------------------------------------------------------------------

!===============================================================================
function circ_von_mieses(theta,mu,kappa,degrees)
!===============================================================================
!  Returns the value of the von Mieses distribution for given mean and 'pointiness'
   implicit none

   real(rs),intent(in) :: theta,mu,kappa
   real(rs)            :: circ_von_mieses,conversion
   logical,intent(in),optional :: degrees

   conversion = pi/180._rs
   if (present(degrees)) then; if (.not.degrees) conversion = 1._rs; endif

   circ_von_mieses = exp(kappa*cos(conversion*(theta - mu)))/(2._rs*pi*BessI0(kappa))

   return

   contains
      function BessI0(x)
      !  Evaluates the modified Bessel function of the first kind at x.
      !  Polynomial approximation taken from Abramowitz & Stegun, 1964, Handbook
      !   of mathematical functions.  See also Numerical Recipes §6.6
         implicit none
         real(rs),intent(in) :: x
         real(rs)            :: BessI0
         real(r8)            :: t

         if (abs(x) < 3.75_r8) then
            t = abs(x/3.75_r8)
            BessI0 = 1._r8 + &
                     3.5156229_r8*t**2 + 3.0899424_r8*t**4 +  1.2067492_r8*t**6 + &
                     0.2659732_r8*t**8 + 0.0360768_r8*t**10 + 0.0045813_r8*t**12
         else
            t = abs(3.75_r8/x)
            BessI0 = (exp(abs(x))/sqrt(abs(x)))*(0.39894228_rs + &
                     0.01328592_r8*t    + 0.00225319_r8*t**2 - 0.00157565_r8*t**3 + &
                     0.00916281_r8*t**4 - 0.02057706_r8*t**5 + 0.02635537_r8*t**6 - &
                     0.01647633_r8*t**7 + 0.00392377_r8*t**8)
         endif
         return
      end function BessI0

end function circ_von_mieses
!-------------------------------------------------------------------------------

!===============================================================================
function circ_test_random_orient(theta,theta0,alpha,degrees) result(pass)
!===============================================================================
! Test whether a set of orientations (i.e., 180-degrees ambiguous), theta_i,
! point in a certain direction, theta0, statistically differently from random,
! using the V-test as modified by Rayleigh
! (test 95 in: 100 Statistical Tests. G.K. Kanji, SAGE Publications.).
   implicit none
   real(rs), intent(in) :: theta(:), theta0
   real(rs), intent(in), optional :: alpha
   logical, optional, intent(in) :: degrees
   real(rs) :: conversion, alpha_in
   real(rs) :: r, mean, V
   logical :: radians, pass
   integer :: n

   n = size(theta)
   if (n < 5) then
      write(0,'(a)') 'statistical: circ_test_random_orient: Error: Cannot ' // &
         'calculate significance for samples < 5'
      stop
   endif

   radians = .false.
   alpha_in = 0.05_rs
   if (present(alpha)) alpha_in = alpha

   if (present(degrees)) radians = .not.degrees
   conversion = pi/180._rs
   if (radians) conversion = 1._rs

   mean = circ_mean(2._rs*theta, degrees=.not.radians)
   r = circ_res_length(2._rs*theta, degrees=.not.radians)
   V = 2._rs*sqrt(2._rs*size(theta))*r*cos(conversion*mean - 2._rs*conversion*theta0)

   ! Lookup values in table and decide on significance
   pass = .false.
   if (V > v_test_table()) pass = .true.

   contains
      function v_test_table() result(value)
         integer :: i
         real(rs) :: value
         integer, parameter, dimension(33) :: table_n = &
            (/ 5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26, &
            27,28,29,30,40,50,60,70,100,500,1000 /)
         real(rs), parameter, dimension(6) :: table_alpha = &
            (/ 0.1, 0.05, 0.01, 0.005, 0.001, 0.0001 /)
         real(rs), parameter :: table(33,6) = transpose(reshape( (/ &
            1.3051_rs, 1.6524_rs, 2.2505_rs, 2.4459_rs, 2.7938_rs, 3.0825_rs, &
            1.3009_rs, 1.6509_rs, 2.2640_rs, 2.4695_rs, 2.8502_rs, 3.2114_rs, &
            1.2980_rs, 1.6499_rs, 2.2734_rs, 2.4858_rs, 2.8886_rs, 3.2970_rs, &
            1.2958_rs, 1.6492_rs, 2.2803_rs, 2.4978_rs, 2.9164_rs, 3.3578_rs, &
            1.2942_rs, 1.6484_rs, 2.2856_rs, 2.5070_rs, 2.9375_rs, 3.4034_rs, &
            1.2929_rs, 1.6482_rs, 2.2899_rs, 2.5143_rs, 2.9540_rs, 3.4387_rs, &
            1.2918_rs, 1.6479_rs, 2.2933_rs, 2.5201_rs, 2.9672_rs, 3.4669_rs, &
            1.2909_rs, 1.6476_rs, 2.2961_rs, 2.5250_rs, 2.9782_rs, 3.4899_rs, &
            1.2902_rs, 1.6474_rs, 2.2985_rs, 2.5290_rs, 2.9873_rs, 3.5091_rs, &
            1.2895_rs, 1.6472_rs, 2.3006_rs, 2.5325_rs, 2.9950_rs, 3.5253_rs, &
            1.2890_rs, 1.6470_rs, 2.3023_rs, 2.5355_rs, 3.0017_rs, 3.5392_rs, &
            1.2885_rs, 1.6469_rs, 2.3039_rs, 2.5381_rs, 3.0075_rs, 3.5512_rs, &
            1.2881_rs, 1.6467_rs, 2.3052_rs, 2.5404_rs, 3.0126_rs, 3.5617_rs, &
            1.2877_rs, 1.6466_rs, 2.3064_rs, 2.5424_rs, 3.0171_rs, 3.5710_rs, &
            1.2874_rs, 1.6465_rs, 2.3075_rs, 2.5442_rs, 3.0211_rs, 3.5792_rs, &
            1.2871_rs, 1.6464_rs, 2.3085_rs, 2.5458_rs, 3.0247_rs, 3.5866_rs, &
            1.2868_rs, 1.6464_rs, 2.3093_rs, 2.5473_rs, 3.0279_rs, 3.5932_rs, &
            1.2866_rs, 1.6463_rs, 2.3101_rs, 2.5486_rs, 3.0308_rs, 3.5992_rs, &
            1.2864_rs, 1.6462_rs, 2.3108_rs, 2.5498_rs, 3.0335_rs, 3.6047_rs, &
            1.2862_rs, 1.6462_rs, 2.3115_rs, 2.5509_rs, 3.0359_rs, 3.6096_rs, &
            1.2860_rs, 1.6461_rs, 2.3121_rs, 2.5519_rs, 3.0382_rs, 3.6142_rs, &
            1.2858_rs, 1.6461_rs, 2.3127_rs, 2.5529_rs, 3.0402_rs, 3.6184_rs, &
            1.2856_rs, 1.6460_rs, 2.3132_rs, 2.5538_rs, 3.0421_rs, 3.6223_rs, &
            1.2855_rs, 1.6460_rs, 2.3136_rs, 2.5546_rs, 3.0439_rs, 3.6258_rs, &
            1.2853_rs, 1.6459_rs, 2.3141_rs, 2.5553_rs, 3.0455_rs, 3.6292_rs, &
            1.2852_rs, 1.6459_rs, 2.3145_rs, 2.5560_rs, 3.0471_rs, 3.6323_rs, &
            1.2843_rs, 1.6456_rs, 2.3175_rs, 2.5610_rs, 3.0580_rs, 3.6545_rs, &
            1.2837_rs, 1.6455_rs, 2.3193_rs, 2.5640_rs, 3.0646_rs, 3.6677_rs, &
            1.2834_rs, 1.6454_rs, 2.3205_rs, 2.5660_rs, 3.0689_rs, 3.6764_rs, &
            1.2831_rs, 1.6453_rs, 2.3213_rs, 2.5674_rs, 3.0720_rs, 3.6826_rs, &
            1.2826_rs, 1.6452_rs, 2.3228_rs, 2.5699_rs, 3.0775_rs, 3.6936_rs, &
            1.2818_rs, 1.6449_rs, 2.3256_rs, 2.5747_rs, 3.0877_rs, 3.7140_rs, &
            1.2817_rs, 1.6449_rs, 2.3260_rs, 2.5752_rs, 3.0890_rs, 3.7165_rs /), (/6,33/)))
         ! The function just checks that the value you asked for alpha
         ! is near to one of those we offer--if not, you get an error
         do i = 1, size(table_alpha)
            if (abs(table_alpha(i) - alpha_in)/table_alpha(i) < 0.1_rs) then
               value = table(minloc(abs(n-table_n),1), i)
               return
            endif
         enddo
         write(0,'(a,f0.6,a)') 'statistical: circ_test_random_orient: v_test_table: ' &
            //'Error: Cannot find a value for alpha near that requested (',alpha_in,')'
         stop
      end function v_test_table
end function circ_test_random_orient
!-------------------------------------------------------------------------------

!===============================================================================
!-------------------------------------------------------------------------------
!  Spherical statistical functions
!-------------------------------------------------------------------------------
!===============================================================================

!===============================================================================
function sph_mean(x, y, z) result(mean)
!===============================================================================
! Compute the mean direction for a set of vectors representing the x, y and z
! directions of points on the unit sphere.  Each input value is normalised to
! the unit sphere even if it isn't on input.
! Output is a three-vector giving the direction as (x,y,z)
   real(rs), intent(in), dimension(:) :: x, y, z
   real(rs) :: mean(3)
   if (size(x) /= size(y) .or. size(y) /= size(z) .or. size(z) /= size(x)) then
      write(0,'(a)') 'statistical: sph_mean: Input arrays must be same length'
      stop
   endif
   mean = (/sum(x), sum(y), sum(z)/)/sph_resultant(x, y, z)
end function sph_mean
!-------------------------------------------------------------------------------

!===============================================================================
function sph_resultant(x, y, z) result(resultant)
!===============================================================================
! Compute the spherical resultant
   real(rs), intent(in), dimension(:) :: x, y, z
   real(rs) :: resultant(3)
   if (size(x) /= size(y) .or. size(y) /= size(z) .or. size(z) /= size(x)) then
      write(0,'(a)') 'statistical: sph_resultant: Input arrays must be same length'
      stop
   endif
   resultant = sqrt(sum(x)**2 + sum(y)**2 + sum(z)**2)
end function sph_resultant
!-------------------------------------------------------------------------------

!===============================================================================
function sph_mean_resultant(x, y, z) result(mean_resultant)
!===============================================================================
   real(rs), intent(in), dimension(:) :: x, y, z
   real(rs) :: mean_resultant(3)
   mean_resultant = sph_resultant(x, y, z)/size(x)
end function sph_mean_resultant
!-------------------------------------------------------------------------------

!===============================================================================
!-------------------------------------------------------------------------------
!  Linear statistical functions
!-------------------------------------------------------------------------------
!===============================================================================

!===============================================================================
function stat_mean(x)
!===============================================================================
! Compute the mean
   real(rs), intent(in), dimension(:) :: x
   real(rs) :: stat_mean
   stat_mean = sum(x)/size(x)
end function stat_mean
!-------------------------------------------------------------------------------

!===============================================================================
function stat_variance(x)
!===============================================================================
! Compute the variance
   real(rs), intent(in), dimension(:) :: x
   real(rs) :: stat_variance
   stat_variance = sum((x - stat_mean(x))**2)/(size(x) - 1)
end function stat_variance
!-------------------------------------------------------------------------------

!===============================================================================
function stat_sd(x)
!===============================================================================
! Compute the standard deviation
   real(rs), intent(in), dimension(:) :: x
   real(rs) :: stat_sd
   stat_sd = sqrt(stat_variance(x))
end function stat_sd
!-------------------------------------------------------------------------------

!===============================================================================
function stat_covariance(x, y)
!===============================================================================
! Compute the covariance between two arrays of the same length
   real(rs), intent(in), dimension(:) :: x, y
   real(rs) :: stat_covariance
   if (size(x) /= size(y)) then
      write(0,'(a)') 'statistical: stat_covariance: Input arrays must be same length'
      stop
   endif
   stat_covariance = sum((x - stat_mean(x))*(y - stat_mean(y)))/size(x)
end function stat_covariance
!-------------------------------------------------------------------------------
!_______________________________________________________________________________
end module statistical


module special_functions
! Special functions
use types, only: dp
use constants, only: i_, pi
use utils, only: stop_error, str
implicit none
private
public wigner3j, getgaunt, getgauntr, Fm, Inu_asympt_sum, Inu_series, &
    Knu_asympt_sum, Inu_formula, Knu_formula, Inu_formula2, Knu_formula2

contains

real(dp) function fact(n) result(r)
integer, intent(in) :: n
r = gamma(n+1.0_dp)
end function

real(dp) function wigner3j(j1, j2, j3, m1, m2, m3) result(r)
! Calculates wigner3j symbols.
integer, intent(in) :: j1, j2, j3 ! angular momentum quantum numbers
integer, intent(in) :: m1, m2, m3 ! magnetic quantum numbers
integer :: k, k1, k2, l1, l2, l3, n1, n2, sgn
if ((abs(m1) > j1) .or. (abs(m2) > j2) .or. (abs(m3) > j3)) then
    print *, "Arguments:"
    print *, j1, j2, j3
    print *, m1, m2, m3
    call stop_error("wigner3j: invalid arguments")
end if
if ((j1 == 0) .and. (j2 == 0) .and. (j3 == 0)) then
    r = 1
    return
end if

l1 = j2 - j1 + j3
l2 = j1 - j2 + j3
l3 = j1 + j2 - j3
if ((m1 + m2 + m3 /= 0) .or. (l1 < 0) .or. (l2 < 0) .or. (l3 < 0)) then
    r = 0
    return
end if
n1 = j1 - m1
n2 = j2 + m2
k1 = max(0, j2-j3-m1, j1-j3+m2)
k2 = min(l3, n1, n2)
if (mod(k1 + j1 + j2 + m3, 2) /= 0) then
    sgn = -1
else
    sgn = 1
end if
r = 0
do k = k1, k2
    r = r + sgn * fr(l1, l1-n2+k) * fr(l2, l2-n1+k) * fr(l3, l3-k) / &
            (fact(k) * fact(n1-k) * fact(n2-k))
    sgn = -sgn
end do
r = r * sqrt(fr(j1+m1, l1) * fr(j2+m2, l2) * fr(j3+m3, l3) * &
        fr(j3-m3, 1+j1+j2+j3) * fact(j1-m1) * fact(j2-m2))
end function

real(dp) function fr(a, b) result(r)
! Returns a!/b!, for a,b >= 0
integer, intent(in) :: a, b
integer :: i
if (a < 0 .or. b < 0) call stop_error("fr(a,b): must satisfy a, b >= 0")
r = 1
if (a < b) then
    do i = a + 1, b
        r = r / i
    end do
else if (a > b) then
    do i = b + 1, a
        r = r * i
    end do
end if
end function

subroutine getgaunt(Lmax, ck)
! Calculates the Gaunt c^k(l1, m1, l2, m2) coefficients
! It returns an array of coefficients for all combinations of k, l1, m1, l2, m2:
!   ck(k, l1, m1, l2, m2) = c^k(l1, m1, l2, m2)
! Indices out of bounds mean that the coefficient is zero.
integer, intent(in) :: Lmax  ! max(l1, l2)
real(dp), allocatable, intent(out) :: ck(:, :, :, :, :) ! ck(k, l1, m1, l2, m2)
integer :: k, l1, m1, l2, m2
allocate(ck(0:2*Lmax, 0:Lmax, -Lmax:Lmax, 0:Lmax, -Lmax:Lmax))
ck = 0
do l1 = 0, Lmax
    do l2 = 0, Lmax
        do m1 = -l1, l1
            do m2 = -l2, l2
                do k = abs(l1-l2), l1+l2, 2
                    if (abs(m1-m2) > k) cycle
                    ck(k, l1, m1, l2, m2) = (-1)**(-m1) * &
                        sqrt(1._dp*(2*l1+1)*(2*l2+1)) * &
                        wigner3j(l1, k, l2, 0, 0, 0) * &
                        wigner3j(l1, k, l2, -m1, m1-m2, m2)
                end do
            end do
        end do
    end do
end do
end subroutine

subroutine getgauntr(Lmax, gr)
integer, intent(in) :: Lmax  ! max(l1, l2)
! gr(i, j, k, l, m, n) = <ij|kl|mn>_R
real(dp), allocatable, intent(out) :: gr(:, :, :, :, :, :)
real(dp), allocatable :: ck(:, :, :, :, :)
integer :: l1, m1, l2, m2, l3, m3
integer :: Lmax2
Lmax2 = 4*Lmax
allocate(ck(0:2*Lmax2, 0:Lmax2, -Lmax2:Lmax2, 0:Lmax2, -Lmax2:Lmax2))
call getgaunt(Lmax2, ck)
allocate(gr(0:Lmax, -Lmax:Lmax, 0:2*Lmax, -2*Lmax:2*Lmax, 0:Lmax, -Lmax:Lmax))
gr = 0
do l1 = 0, Lmax
    do l2 = 0, 2*Lmax
        do l3 = 0, Lmax
            do m1 = -l1, l1
                do m2 = -l2, l2
                    do m3 = -l3, l3
                        gr(l1, m1, l2, m2, l3, m3) = &
                            gauntr(l1, m1, l2, m2, l3, m3, ck, Lmax2)
                    end do
                end do
            end do
        end do
    end do
end do
end subroutine

real(dp) recursive function gauntr(l1, m1, l2, m2, l3, m3, ck, Lmax) result(r)
integer, intent(in) :: l1, m1, l2, m2, l3, m3, Lmax
real(dp), intent(in) :: ck(0:, 0:, -Lmax:, 0:, -Lmax:)
if (m1 /= 0 .and. m2 /= 0 .and. m3 /= 0) then
    ! Case A
    r = 2*ck(l2, l1, m2+m3, l3, m3) &
            * real(U(m1, m2+m3) * U(m2, m2) * U(m3, m3), dp) &
        + 2*ck(l2, l1, m2-m3, l3, -m3) &
            * real(U(m1, m2-m3) * U(m2, m2) * U(m3, -m3), dp)
else if (m1 /= 0 .and. m2 /= 0 .and. m3 == 0) then
    ! Case B
    r = 2*ck(l2, l1, m2, l3, 0) * real(U(m1, m2) * U(m2, m2), dp)
else if (m1 /= 0 .and. m2 == 0 .and. m3 /= 0) then
    ! Convert to case B
    r = gauntr(l1, m1, l3, m3, l2, m2, ck, Lmax)
else if (m1 == 0 .and. m2 /= 0 .and. m3 /= 0) then
    ! Convert to case B
    r = gauntr(l3, m3, l2, m2, l1, m1, ck, Lmax)
else if (m2 == 0 .and. m3 == 0) then
    ! Case C
    r = ck(l2, l1, 0, l3, 0) * delta(m1, 0)
else if (m1 == 0 .and. m3 == 0) then
    ! Convert to case C
    r = gauntr(l2, m2, l1, m1, l3, m3, ck, Lmax)
else if (m1 == 0 .and. m2 == 0) then
    ! Convert to case C
    r = gauntr(l3, m3, l1, m1, l2, m2, ck, Lmax)
else
    r = 0 ! silence gfortran warning
    call stop_error("Internal error.")
end if

contains

integer function delta(a, b) result(r)
integer, intent(in) :: a, b
if (a == b) then
    r = 1
else
    r = 0
end if
end function

complex(dp) function U(mu, m) result(r)
integer, intent(in) :: mu, m
if (mu > 0) then
    r = (delta(mu, m) + (-1)**m * delta(mu, -m))/sqrt(2._dp)
else if (mu == 0) then
    r = delta(0, m)
else
    r = (delta(mu, -m) - (-1)**m * delta(mu, m))/(i_ * sqrt(2._dp))
end if
end function

end function

subroutine Fm(maxm, t, F)
! Calculates F_m(t) for m=0,1,..,maxm, where
!
!     F_m(t) = \int_0^1 u^(2m) e^(-tu^2) du
!
! And assigns the result to the array F(m) = F_m(t).
!
! Conditions on max, t: 0 <= maxm <= 500, t >= 0.
!
! This routine is tested for absolute accuracy 1e-15 and relative accuracy
! 1e-12 for all maxm = 0..500 and all values "t" from the interval
! 0 <= t <= 2e8.
!
! The algorithm is based on [1], all equations are references from there. The
! idea is to use series expansion for F_maxm(t) and then the recursive relation
! (24) downwards to calculate F_m(t) for m < maxm. For t >= maxm + 0.5, the
! series would take too many iterations to converge and also the downwards
! relation (24) becomes inaccurate, so we calculate F_0(t) directly and use
! (24) upwards.
!
! [1] I. Shavitt: Methods in Computational Physics (Academic Press Inc., New
! York, 1963), vol. 2
integer, intent(in) :: maxm
real(dp), intent(in) :: t
! The array F(0:maxm) will be equal to F(m) = F_m(t) for m = 0..maxm
real(dp), intent(out) :: F(0:)

real(dp) :: s, term
integer :: m
if (maxm < 0 .or. maxm > 500) &
    call stop_error("Fm: only works for 0 <= m <= 500")
if (t < 0) call stop_error("Fm: only works for t >= 0")
if (ubound(F, 1) /= maxm) call stop_error("Fm: invalid bounds on F")

if (t < maxm + 0.5_dp) then
    ! Series expansion for F_m(t), between equations (24) and (25).
    ! Since (2*t)/(2*maxm+1) < 1, this will converge fast:
    term = 1._dp / (2*maxm + 1)
    s = term
    m = 1
    do while (term/s > epsilon(1._dp))
        term = term * (2*t) / (2*maxm + 2 * m + 1)
        ! "s" will only change if term/s > machine eps
        s = s + term
        m = m + 1
    end do
    F(maxm) = s * exp(-t)
    ! Eq. (24) downwards, for t < maxm+0.5, this converges well:
    do m = maxm-1, 0, -1
        F(m) = (2*t*F(m + 1) + exp(-t)) / (2*m + 1)
    end do
else
    ! Eq. for F_0(t) on page 7:
    F(0) = 0.5_dp * sqrt(pi/t) * erf(sqrt(t))
    ! Eq. (24) upwards, for t >= maxm+0.5, this converges well:
    do m = 0, maxm-1
        F(m + 1) = ((2*m + 1)*F(m) - exp(-t)) / (2*t)
    end do
endif
end subroutine

real(dp) function Knu_asympt_sum(nu, x) result(s)
! If nu = k + 1/2 for k = 0, 1, 2, ..., then the series terminates (the result
! is a polynomial) and this function returns an exact result for all "x".
real(dp), intent(in) :: nu, x
real(dp) :: term, max_term
integer :: k
term = 1
s = term
max_term = abs(term)
k = 1
do while (term/s > epsilon(1._dp))
    term = term * (4*nu**2-(2*k-1)**2)/(8*k*x)
    if (abs(term) > max_term) max_term = abs(term)
    if (max_term > 1e100_dp) then
        call stop_error("Knu asymptotic series does not converge.")
    end if
    s = s + term
    k = k + 1
end do

if (max_term / abs(s) > 10) then
    call stop_error("Knu asymptotic series lost too many significant digits.")
end if
end function

real(dp) function Inu_asympt_sum(nu, x) result(s)
! If nu = k + 1/2 for k = 0, 1, 2, ..., then the series terminates (the result
! is a polynomial), however, unlike Knu_asympt_sum(), this polynomial is only
! valid asymptotically. The exact result contains functions sinh(x) and
! cosh(x). As such, sinh(x)/exp(x) = cosh(x)/exp(x) = 1/2 for
! x > -log(epsilon(1._dp))/2. Then this function returns exact result for the
! given floating point precision for all x satisfying the inequality.
real(dp), intent(in) :: nu, x
real(dp) :: term, max_term
integer :: k
term = 1
s = term
max_term = abs(term)
k = 1
do while (term/s > epsilon(1._dp))
    term = - term * (4*nu**2-(2*k-1)**2)/(8*k*x)
    if (abs(term) > max_term) max_term = abs(term)
    if (max_term > 1e100_dp) then
        call stop_error("Inu asymptotic series does not converge.")
    end if
    s = s + term
    k = k + 1
end do

if (max_term / abs(s) > 10) then
    call stop_error("Inu asymptotic series lost too many significant digits.")
end if
end function

real(dp) function hyp0f1(a, x) result(s)
real(dp), intent(in) :: a, x
real(dp) :: term, max_term
integer :: k
term = 1
s = term
max_term = abs(term)
k = 1
do while (term/s > epsilon(1._dp))
    term = term * x/(k*(a+k-1))
    if (abs(term) > max_term) max_term = abs(term)
    if (max_term > 1e100_dp) then
        call stop_error("hyp0f1: series does not converge.")
    end if
    s = s + term
    k = k + 1
end do

if (max_term / abs(s) > 10) then
    call stop_error("hyp0f1: series lost too many significant digits.")
end if
end function

real(dp) function Inu_series(nu, x) result(r)
! Returns the modified Bessel function of the first kind using the series
! expansion around x=0.
real(dp), intent(in) :: nu, x
r = (x/2)**nu / gamma(nu+1) * hyp0f1(nu+1, x**2/4)
end function

subroutine Knu_formula(maxk, x, K)
! Returns K(k) = K_{k+1/2}(x) / exp(-x) for k=-1,0,1,...,maxk.
integer, intent(in) :: maxk
real(dp), intent(in) :: x
real(dp), intent(out) :: K(-1:)
integer :: l
K(-1) = sqrt(pi/(2*x))
K(0) = K(-1)
do l = 0, maxk-1
    ! K_{nu+1} = K_{nu-1} + 2*nu*K_nu/x
    K(l + 1) = K(l-1) + (2*l + 1)*K(l)/x
end do
end subroutine

subroutine Inu_formula(maxk, x, I)
! Returns I(k) = I_{k+1/2}(x) / exp(x) for k=-1,0,1,...,maxk.
integer, intent(in) :: maxk
real(dp), intent(in) :: x
real(dp), intent(out) :: I(-1:)
integer :: l
I(-1) = (1+exp(-2*x)) / sqrt(2*pi*x)
! I(0) = (1-exp(-2*x)) / sqrt(2*pi*x)
if (x > -log(epsilon(1._dp))/2) then
    ! (1-exp(-2*x)) = 1 in floating point precission
    I(0) = 1 / sqrt(2*pi*x)
else
    ! (1-exp(-2*x)) = 2*sinh(x)/exp(x) to avoid cancellation
    I(0) = sqrt(2/(pi*x)) * sinh(x)/exp(x)
end if
do l = 0, maxk-1
    ! I_{nu+1} = I_{nu-1} - 2*nu*I_nu/x
    I(l + 1) = I(l-1) - (2*l + 1)*I(l)/x
end do
end subroutine

real(dp) function Inu_formula2(k, x) result(r)
integer, intent(in) :: k
real(dp), intent(in) :: x
select case (k)
    case (0)
        ! r = sinh(x) / exp(x)
        if (x < 20) then
            r = sinh(x) / exp(x)
        else
            r = 1._dp / 2
        end if
    case (1)
        ! r = -sinh(x)/x + cosh(x)
        ! r = r * sqrt(2/(pi*x)) / exp(x)
        if (x < 0.55_dp) then
            r = x**2/3 + x**4/30 + x**6/840 + x**8/45360 + x**10/3991680 + &
                x**12/518918400 + x**14/93405312e3_dp
            r = r / exp(x)
        else if (x < 2) then
            r = (-1.0118340437504393201742626606e-13_dp + &
                    x*(1.816670640113517482116741309e-12_dp + &
                    x*(0.333333333318047257036705475493_dp + &
                    x*(0.0283477684328350973136495456416_dp + &
                    x*(0.0236972901524850660936691284628_dp + &
                    x*(0.0018095002919993302530473889535_dp + &
                    x*(0.000376379638016770111327098946609_dp + &
                    (0.0000200246480593843172713997406232_dp + &
                    1.01338637272678665804111511983e-6_dp*x)*x)))))))/ &
                (1 + x*(1.08504330505794283765963608202_dp + &
                    x*(0.556135176398351735247605123725_dp + &
                    x*(0.177204358493610809522295217793_dp + &
                    x*(0.0387591827785532218461461492913_dp + &
                    x*(0.00603331772767809320892209353842_dp + &
                    x*(0.000663930390602843320578606798458_dp + &
                    (0.0000484437498700383824299885362686_dp + &
                    1.88315077527785406856560709781e-6_dp*x)*x)))))))
        else if (x < 20) then
            r = (-sinh(x)/x + cosh(x)) / exp(x)
        else
            r = (-1/x + 1) / 2
        end if
    case (2)
        ! r = (3/x**2 + 1)*sinh(x) - 3/x*cosh(x)
        ! r = r * sqrt(2/(pi*x)) / exp(x)
        if (x < 0.4_dp) then
            r = x**3/15 + x**5/210 + x**7/7560 + x**9/498960 + &
                x**11/51891840 + x**13/7783776e3_dp
            r = r / exp(x)
        else if (x < 3.5_dp) then
            r = (2.53492679940778614368716713944e-12_dp + &
                    x*(-4.54239143359406142775391525584e-11_dp + &
                    x*(3.74155600551604503226833667911e-10_dp + &
                    x*(0.0666666647818812413079530441494_dp + &
                    x*(0.00828258168209346350068333077357_dp + &
                    x*(0.00316314651226673854191486006661_dp + &
                    x*(0.000312916425508586674670599989463_dp + &
                    (0.0000347881775004914918533122949261_dp + &
                    1.78379773794153349607916665442e-6_dp*x)*x)))))))/ &
                (1. + x*(1.12423862743404991052489502731_dp + &
                    x*(0.600257501089318988530867089925_dp + &
                    x*(0.20062393658095786500607161529_dp + &
                    x*(0.0464529738128345227818430451247_dp + &
                    x*(0.00775200781581904134897323422714_dp + &
                    x*(0.000932283869002308809130049094732_dp + &
                    (0.0000765450448110628850893821308195_dp + &
                    3.64978189893775492541031628736e-6_dp*x)*x)))))))
        else if (x < 8) then
            r = (-0.0500329770733375148059871692299_dp + &
                    x*(0.225443974816227263854027844348_dp + &
                    x*(-0.490706738714676572173733908052_dp + &
                    x*(0.754739228306267786750520915722_dp + &
                    x*(-0.0229222956512753039643375612586_dp + &
                    x*(0.0417199171935382735527783646423_dp + &
                    x*(0.00129242688582393560040014185308_dp + &
                    (0.000436655909016956929989211236885_dp + &
                    0.0000544588062620298286123134699247_dp*x)*x)))))))/ &
                (1 + x*(11.1481461018360358000411784178_dp + &
                    x*(2.95111664564331863128521306942_dp + &
                    x*(2.07069035717497213861002964422_dp + &
                    x*(0.212130624675779325122087859297_dp + &
                    x*(0.0985267048591193186479900210954_dp + &
                    x*(0.00581026870781213052737501655128_dp + &
                    (0.00120128946303470807826705767304_dp + &
                    0.000108903528444754760503502120599_dp*x)*x)))))))
        else if (x < 20) then
            r = ((3/x**2 + 1)*sinh(x) - 3/x*cosh(x)) / exp(x)
        else
            r = (3/x**2 - 3/x + 1) / 2
        end if
    case (3)
        ! r = -(15/x**3 + 6/x)*sinh(x) + (15/x**2 + 1)*cosh(x)
        ! r = r / exp(x)
        if (x < 0.4_dp) then
            r = x**4/105 + x**6/1890 + x**8/83160 + x**10/6486480 + &
                x**12/778377600 + x**14/132324192e3_dp
            r = r / exp(x)
        else if (x < 3) then
            r = (-3.70655078828583097759525479916e-13_dp + &
                    x*(7.15112302218910770115285755762e-12_dp + &
                    x*(-6.36681926888695741582309642988e-11_dp + &
                    x*(3.47928680854080370346525732791e-10_dp + &
                    x*(0.00952380821395522376879618243177_dp + &
                    x*(0.00113757240229334056047517957181_dp + &
                    x*(0.000297467643525496580117283299361_dp + &
                    (0.0000243340659637433371695954961197_dp + &
                1.81721245776908511864649367981e-6_dp*x)*x)))))))/ &
                (1 + x*(1.11944472257087316750869453522_dp + &
                    x*(0.595124068593635706143579962619_dp + &
                    x*(0.197986316667328417652509149837_dp + &
                    x*(0.0456127952595471262482188760838_dp + &
                    x*(0.00757090880409778905789353557549_dp + &
                    x*(0.000905726554901565254770825575224_dp + &
                    (0.0000739095656995355486962496918923_dp + &
                    3.54519707102049776194411547746e-6_dp*x)*x)))))))
        else if (x < 8.5_dp) then
            r = (0.00117649571172537032041386386937_dp + &
                    x*(-0.00530534669296740084953876529485_dp + &
                    x*(0.0113989437968364216304855248904_dp + &
                    x*(-0.0155143209720413375494757271933_dp + &
                    x*(0.0245092943569822333734792982989_dp + &
                    x*(-0.00194266321525633715561142461716_dp + &
                    x*(0.00125839658564675731614612557048_dp + &
                    (-0.0000560593512807954817946224257333_dp + &
                    0.0000154307073445195296381347198964_dp*x)*x)))))))/ &
                (1 + x*(1.93920721196223643040357762209_dp + &
                    x*(0.871960706430017695531414950855_dp + &
                    x*(0.294335907964445235622348955601_dp + &
                    x*(0.076510324944994462960832902772_dp + &
                    x*(0.0103358291871056058873144950985_dp + &
                    x*(0.00249717323564249173430366673788_dp + &
                    (0.0000729070672630135675918235119142_dp + &
                    0.0000308632011694791287440146822781_dp*x)*x)))))))
        else if (x < 20) then
            r = (-(15/x**3 + 6/x)*sinh(x) + (15/x**2 + 1)*cosh(x)) / exp(x)
        else
            r = (-15/x**3 + 15/x**2 - 6/x  + 1)/2
        end if
    case (4)
        ! r = (105/x**4 + 45/x**2 + 1)*sinh(x) - (105/x**3 + 10/x)*cosh(x)
        ! r = r / exp(x)
        if (x < 0.2_dp) then
            r = x**5/945 + x**7/20790 + x**9/1081080 + x**11/97297200 + &
                    x**13/132324192e2_dp
            r = r / exp(x)
        else if (x < 1.7_dp) then
            r = (8.24833340467311342180121686171e-18_dp + &
                x*(-2.9977388208095462038421382427e-16_dp + &
                x*(4.98591599598783667120520966419e-15_dp + &
                x*(-5.04172127797261339201651796769e-14_dp + &
                x*(3.47424275623446932695212209666e-13_dp + &
                x*(0.00105820105646713443251629043736_dp + &
                x*(0.0000979757728258499019673125884795_dp + &
                (0.0000182024072642408317859820498652_dp + &
                1.0631472458547091790087783848e-6_dp*x)*x))))))) / &
            (1 + x*(1.09258709917337245791086210753_dp + &
                x*(0.564333846348740813775052159905_dp + &
                x*(0.181503092836557003863165983269_dp + &
                x*(0.040177538019272720474585552471_dp + &
                x*(0.00635509731709913059075978583153_dp + &
                x*(0.000715397138065847382814527384553_dp + &
                (0.0000540407967369787069953788458276_dp + &
                2.26320060646140077482435126776e-6_dp*x)*x)))))))
        else if (x < 4) then
            r = (-1.79380868029518008655845945341e-7_dp + &
                x*(1.42021959889593932447404701528e-6_dp + &
                x*(-5.3621673060507414018999203431e-6_dp + &
                x*(0.0000128612071905009120973461141937_dp + &
                x*(-0.0000220283666472339963720124703845_dp + &
                x*(0.00108692026226442881323459546524_dp + &
                x*(-0.000108914780493366312610770062505_dp + &
                (0.0000213026860907556990203197490202_dp - &
                2.40044294668610963152692356425e-6_dp*x)*x))))))) / &
            (1 + x*(0.92511576565864173804826819565_dp + &
                x*(0.376185570863101848786874779376_dp + &
                x*(0.0979599622990753625780606726782_dp + &
                x*(0.0139543384283183184757129378369_dp + &
                x*(0.00167710554949622675142353677903_dp + &
                x*(-0.0000841270733243543647065400772874_dp + &
                (-4.04735930419963375054951672688e-6_dp - &
                4.82907242383463140296057166244e-6_dp*x)*x)))))))
        else if (x < 10) then
            ! Produced by:
            ! FortranForm[HornerForm[MiniMaxApproximation[((105/x^4 + 45/x^2 +
            !   1)*Sinh[x]-(105/x^3 + 10/x)*Cosh[x])/Exp[x], {x, {4, 10}, 8, 8},
            !   WorkingPrecision->30][[2, 1]]]]
            r = (0.000395502959013236968661582656143_dp + &
                x*(-0.001434648369704841686633794071_dp + &
                x*(0.00248783474583503473135143644434_dp + &
                x*(-0.00274477921388295929464613063609_dp + &
                x*(0.00216275018107657273725589740499_dp + &
                x*(-0.000236779926184242197820134964535_dp + &
                x*(0.0000882030507076791807159699814428_dp + &
                (-4.62078105288798755556136693122e-6_dp + &
                8.23671374777791529292655504214e-7_dp*x)*x))))))) / &
            (1 + x*(0.504839286873735708062045336271_dp + &
                x*(0.176683950009401712892997268723_dp + &
                x*(0.0438594911840609324095487447279_dp + &
                x*(0.00829753062428409331123592322788_dp + &
                x*(0.00111693697900468156881720995034_dp + &
                x*(0.000174719963536517752971223459247_dp + &
                (7.22885338737473776714257581233e-6_dp + &
                1.64737453771748367647332279826e-6_dp*x)*x)))))))
        else if (x < 20) then
            r = (1.49435717183021678294278540018_dp + &
                x*(-1.9954827594990599398954087063_dp + &
                x*(1.19185825369343226912112655137_dp + &
                x*(-0.40866680980235804096143699423_dp + &
                x*(0.0852839860059780325406440673318_dp + &
                (-0.00980617919194154929317057489645_dp + &
                0.000550291361244287676343295379476_dp*x)*x)))))/&
            (1 + x*(0.420439518058743727857466136746_dp + &
                x*(0.144024726914933127664739439568_dp + &
                x*(0.035261250406130055921113600336_dp + &
                x*(0.0349770458351085078647522073879_dp + &
                (-0.00860653991097136433951965579037_dp + &
                0.00110058277850687516223459976889_dp*x)*x)))))
        else
            r = (105/x**4 - 105/x**3 + 45/x**2 - 10/x + 1)/2
        end if
    case default
        r = -1 ! For compiler warning "fix"
        call stop_error("k = " // str(k) // " not implemented.")
end select
r = r * sqrt(2/(pi*x))
end function

real(dp) function Knu_formula2(k, x) result(r)
integer, intent(in) :: k
real(dp), intent(in) :: x
select case (k)
    case (0)
        r = 1
    case (1)
        r = 1/x + 1
    case (2)
        r = 3/x**2 + 3/x + 1
    case (3)
        r = 15/x**3 + 15/x**2 + 6/x + 1
    case (4)
        r = 105/x**4 + 105/x**3 + 45/x**2 + 10/x + 1
    case default
        r = 0 ! silence gfortran warning
        call stop_error("k = " // str(k) // " not implemented.")
end select
r = r * sqrt(pi/(2*x))
end function

end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_laplacian_routines) invert_scalar_laplacian_gaussian_grid

contains
    !     subroutine islapgc(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b,
    !                        mdab, ndab, wshsgc, pertrb, ierror)
    !
    !     islapgc inverts the laplace or helmholz operator on a Gaussian
    !     grid using o(n**2) storage. given the
    !     spherical harmonic coefficients a(m, n) and b(m, n) of the right
    !     hand side slap(i, j), islapgc computes a solution sf(i, j) to
    !     the following helmhotz equation :
    !
    !           2                2
    !     [d(sf(i, j))/dlambda /sint + d(sint*d(sf(i, j))/dtheta)/dtheta]/sint
    !
    !                   - xlmbda * sf(i, j) = slap(i, j)
    !
    !      where sf(i, j) is computed at the Gaussian colatitude point theta(i)
    !      (see nlat as an input argument) and longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for i=1, ..., nlat and j=1, ..., nlon.
    !
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct longitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     isym   this parameter should have the same value input to subroutine
    !            shagc to compute the coefficients a and b for the scalar field
    !            slap.  isym is set as follows:
    !
    !            = 0  no symmetries exist in slap about the equator. scalar
    !                 synthesis is used to compute sf on the entire sphere.
    !                 i.e., in the array sf(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !           = 1  sf and slap are antisymmetric about the equator. the
    !                synthesis used to compute sf is performed on the
    !                northern hemisphere only.  if nlat is odd, sf(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, sf(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !           = 2  sf and slap are symmetric about the equator. the
    !                synthesis used to compute sf is performed on the
    !                northern hemisphere only.  if nlat is odd, sf(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, sf(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !   nt       the number of solutions. in the program that calls islapgc
    !            the arrays sf, a, and b can be three dimensional in which
    !            case multiple solutions are computed. the third index
    !            is the solution index with values k=1, ..., nt.
    !            for a single solution set nt=1. the description of the
    !            remaining parameters is simplified by assuming that nt=1
    !            and sf, a, b are two dimensional.
    !
    !   xlmbda   a one dimensional array with nt elements. if xlmbda is
    !            is identically zero islapgc solves poisson's equation.
    !            if xlmbda > 0.0 islapgc solves the helmholtz equation.
    !            if xlmbda < 0.0 the nonfatal error flag ierror=-1 is
    !            returned. negative xlambda could result in a division
    !            by zero.
    !
    !   ids      the first dimension of the array sf as it appears in the
    !            program that calls islapgc.  if isym = 0 then ids must be at
    !            least nlat.  if isym > 0 and nlat is even then ids must be
    !            at least nlat/2. if isym > 0 and nlat is odd then ids must
    !            be at least (nlat + 1)/2.
    !
    !   jds      the second dimension of the array sf as it appears in the
    !            program that calls islapgc. jds must be at least nlon.
    !
    !
    !   a, b      two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field slap. a, b must be computed by shagc
    !            prior to calling islapgc.
    !
    !
    !   mdab     the first dimension of the arrays a and b as it appears
    !            in the program that calls islapgc.  mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !   ndab     the second dimension of the arrays a and b as it appears
    !            in the program that calls islapgc. ndbc must be at least
    !            least nlat.
    !
    !            mdab, ndab should have the same values input to shagc to
    !            compute the coefficients a and b.
    !
    !     wshsgc an array which must be initialized by subroutine shsgci
    !            once initialized, wshsgc can be used repeatedly by islapgc
    !            as long as nlon and nlat remain unchanged.  wshsgc must
    !            not be altered between calls of islapgc.
    !
    !
    !    lshsgc  the dimension of the array wshsgc as it appears in the
    !            program that calls islapgc.  let
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgc must be at least
    !
    !               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !
    !    sf      a two or three dimensional arrays (see input parameter nt) that
    !            inverts the scalar laplacian in slap.  sf(i, j) is given at
    !            the colatitude
    !
    !                 theta(i) = (i-1)*pi/(nlat-1)
    !
    !            and longitude
    !
    !                 lambda(j) = (j-1)*2*pi/nlon
    !
    !            for i=1, ..., nlat and j=1, ..., nlon.
    !
    !   pertrb  a one dimensional array with nt elements (see input
    !           parameter nt). in the discription that follows we assume
    !           that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always
    !           returned because the helmholtz operator is invertible.
    !           if xlmbda = 0.0 then a solution exists only if a(1, 1)
    !           is zero. islapgc sets a(1, 1) to zero. the resulting
    !           solution sf(i, j) solves poisson's equation with
    !           pertrb = a(1, 1)/(2.*sqrt(2.)) subtracted from the
    !           right side slap(i, j).
    !
    !  ierror    a parameter which flags errors in input parameters as follows:
    !
    !            =-1  xlmbda is input negative (nonfatal error)
    !            = 0  no errors detected
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of ids
    !            = 6  error in the specification of jds
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsgc
    !
    module subroutine islapgc(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
        mdab, ndab, wshsgc, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(in)  :: xlmbda(:)
        real(wp),    intent(out) :: sf(ids, jds, nt)
        integer(ip), intent(in)  :: ids
        integer(ip), intent(in)  :: jds
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsgc(:)
        real(wp),    intent(out) :: pertrb(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)                  :: required_wavetable_size
        type(ScalarSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsgc(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, ids, jds, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsgc, ierror)

        ! Check sign of xlmbda
        if (any(xlmbda < ZERO)) then
            ierror = -1
        end if

        ! Check error flag
        if (ierror /= 0) return

        call invert_scalar_laplacian_lower_utility_routine(nlat, nlon, isym, &
            nt, xlmbda, pertrb, sf, a, b, wshsgc, shsgc, ierror)

    end subroutine islapgc

end submodule invert_scalar_laplacian_gaussian_grid


      INTEGER FUNCTION ignnbn(n,p)
C**********************************************************************
C
C     INTEGER FUNCTION IGNNBN( N, P )
C
C                GENerate Negative BiNomial random deviate
C
C
C                              Function
C
C
C     Generates a single random deviate from a negative binomial
C     distribution.
C
C
C                              Arguments
C
C
C     N  --> Required number of events.
C                              INTEGER N
C     JJV                      (N > 0)
C
C     P  --> The probability of an event during a Bernoulli trial.
C                              DOUBLE PRECISION P
C     JJV                      (0.0 < P < 1.0)
C
C
C
C                              Method
C
C
C     Algorithm from page 480 of
C
C     Devroye, Luc
C
C     Non-Uniform Random Variate Generation.  Springer-Verlag,
C     New York, 1986.
C
C**********************************************************************
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION p
      INTEGER n
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION y,a,r
C     ..
C     .. External Functions ..
C     JJV changed to call SGAMMA directly
C     DOUBLE PRECISION gengam
      DOUBLE PRECISION sgamma
      INTEGER ignpoi
C      EXTERNAL gengam,ignpoi
      EXTERNAL sgamma,ignpoi
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC real
C     ..
C     .. Executable Statements ..
C     Check Arguments
C     JJV changed argumnet checker to abort if N <= 0
C     See Rand,c
C     Generate Y, a random gamma (n,(1-p)/p) variable
C     JJV Note: the above parametrization is consistent with Devroye,
C     JJV       but gamma (p/(1-p),n) is the equivalent in our code
 10   r = dble(n)
      a = p/ (1.0-p)
C      y = gengam(a,r)
      y = sgamma(r)/a

C     Generate a random Poisson(y) variable
      ignnbn = ignpoi(y)
      RETURN

      END


! =====================================================================
! subroutine VAHO
!
! This subroutine constructs a polar simple harmonic oscillator
! potential. It may be used to generate an inital wavefuction that is
! correctly aligned with the potential minimum of the simple harmonic
! oscillator ring.
! ---------------------------------------------------------------------
      subroutine VAHO(nRP,nR,nP,r0,p0,kR,kP,R,P,V)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: pi
      double precision :: r0
      double precision :: p0
      double precision :: kR
      double precision :: kP
      double precision :: R(nR)
      double precision :: P(nP)
      double precision :: V(nRP)

      integer :: i
      integer :: j
      integer :: k

      pi = 3.14159265358979323846d0

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            if (P(j).le.(1.5*pi)) then
               V(k) = 0.5d0*(kR*(R(i)-r0))**2+0.5d0*(kP*r0*(P(j)-p0))**2
            else
               V(k) = 0.5d0*(kR*(R(i)-r0))**2+0.5d0*(kP*r0*(P(j)-p0- 2.0d0*pi))**2
            endif
         enddo
      enddo

      return
      end
! =====================================================================


program main
  implicit none
  integer*4 :: nd, Ns, Nt

  nd = 1
  Ns = 1000
  Nt = 1000
  call test(nd, Ns, Nt)
end

subroutine test(nd, Ns, Nt)
  use iso_c_binding
  implicit none
  include 'kernels.f90'
  integer*4 :: i, nd, Ns, Nt
  real*8 :: Xs(Ns*3), Xt(Nt*3), thresh
  complex*16 :: zk, Vs(Ns*nd), Vt(Nt*nd), Vt_ref(Nt*nd)
  double precision :: omp_get_wtime, tt
  real*4 :: rand

  zk = (1.0,1.0)
  thresh = 1.0e-12

  call srand(0)
  do i=1, Ns*3
    Xs(i) = rand(0)
  enddo
  do i=1, Ns
    Vs(i) = rand(0)
  enddo
  do i=1, Nt*3
    Xt(i) = rand(0)
  enddo
  do i=1, Nt
    Vt(i) = (0,0)
    Vt_ref(i) = (0,0)
  enddo

  tt = -omp_get_wtime()
  do i=1,100
    call helm3d_d(nd, zk, Xs, Vs, ns, Xt, nt, Vt_ref, thresh)
  enddo
  tt = tt + omp_get_wtime()
  print*, "Unvectorized : ", tt

  tt = -omp_get_wtime()
  do i=1,100
    call helm3d_vec_d(nd, zk, Xs, Vs, ns, Xt, nt, Vt, thresh)
  enddo
  tt = tt + omp_get_wtime()
  print*, "Vectorized : ", tt

  print*, "Maximum relative error : ", maxval(abs(Vt_ref - Vt)) / maxval(abs(Vt_ref));
endsubroutine


subroutine downhill(n,func,xstart,fstart,stepi,epsf,itmin,iter)
!
!   n           dimension of the problem
!   func        function
!   xstart      starting values
!   fstart      conrespoding function value
!   stepi       relative stepsize for initial simplex
!   epsf        epsilon for termination
!   itmin       termination is tested if itmin < it
!   iter        maximum number of iterations
!

    use NumType
    implicit none
    integer :: n, iter, itmin
    real(dp), external :: func
    real(dp) :: xstart(1:n), fstart, stepi, epsf
    real(dp), parameter :: alph=1._dp, gamm=2._dp, &
                            rho=0.5_dp, sig=0.5_dp
    real(dp) :: xi(1:n,1:n+1), x(1:n,1:n+1), &
        fi(1:n+1), f(1:n+1),  &
        x0(1:n), xr(1:n), xe(1:n), xc(1:n), &
        fxr, fxe, fxc, deltaf
    integer :: i, ii, it

    xi(1:n,1) = xstart(1:n);    fi(1) = fstart
    do i = 2, n+1
        xi(1:n,i)=xi(1:n,1)
        xi(i-1,i)=xi(i-1,i)*(1+stepi)
        fi(i)=func(xi(1:n,i))
    end do

    do it = 1, iter

        do i = 1, n+1                           ! ordering
            ii = minloc(fi(1:n+1),dim=1)
            x(1:n,i) = xi(1:n,ii);  f(i) = fi(ii)
            fi(ii) = huge(0._dp)
        end do
        xi(1:n,1:n+1) = x(1:n,1:n+1)
        fi(1:n+1) = f(1:n+1)

        x0(1:n) = sum(x(1:n,1:n),dim=2)/n   ! central

        if ( itmin < it ) then              ! condition for exit
            deltaf = (f(n)-f(1))
            !write(777,*) it,deltaf
            if(deltaf < epsf ) then
                exit
            end if
        end if

        xr(1:n) = x0(1:n)+alph*(x0(1:n)-x(1:n,n+1))
        fxr = func(xr)
        if( fxr < f(n) .and. &              ! reflection
                f(1) <= fxr ) then
            xi(1:n,n+1) = xr(1:n);  fi(n+1) = fxr
            cycle

        else if ( fxr < f(1) ) then         ! expansion
            xe(1:n) = x0(1:n)+gamm*(x0(1:n)-x(1:n,n+1))
            fxe = func(xe)
            if( fxe < fxr ) then
                xi(1:n,n+1) = xe(1:n);  fi(n+1) = fxe
                cycle
            else
                xi(1:n,n+1) = xr(1:n);  fi(n+1) = fxr
                cycle
            end if

        else if ( fxr >= f(n) ) then        ! contraction
            xc(1:n) = x(1:n,n+1)+rho*(x0(1:n)-x(1:n,n+1))
            fxc = func(xc)
            if( fxc <= f(n+1) ) then
                xi(1:n,n+1) = xc(1:n);  fi(n+1) = fxc
                cycle
            else                                 ! reduction
                 do i = 2, n+1
                    xi(1:n,i) = x(1:n,1)+sig*(x(1:n,i)-x(1:n,1))
                    fi(i) = func(xi(1:n,i))
                end do
                cycle
            end if

        end if

    end do

    xstart(1:n)=xi(1:n,1); fstart = fi(1)

end subroutine downhill


      subroutine compute_c5(n_A,n_Athth,n_Axx,n_B,n_K,n_rho,x,Nx,myzero,
     &phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 myzero
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_K(Nx)
      real*8 n_rho(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = -0.8333333333333333D-1 * n_K(i) ** 2 + 0.2500000000000000D0 *
     # n_rho(i) + 0.1250000000000000D0 / n_A(i) ** 2 * n_Axx(i) ** 2 + 0
     #.2500000000000000D0 / n_B(i) ** 2 * n_Athth(i) ** 2
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END