module quadglobal
use qdmodule
implicit none
integer ndebug, ndigits, nerror, nquadl
end module

! program tquadtsq
subroutine f_main

!   David H. Bailey      2004-12-16
!   This is the Quad-Double Fortran-90 version.

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.

!   This program demonstrates the quadrature routine 'quadtsq', which employs
!   the tanh-sinh function.  The function quadtsq is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   finite open interval.  It can also be used for certain integrals on
!   infinite intervals, by making a suitable change of variable -- see below.
!   While this routine is not quite as efficient as quadgs for functions that
!   are regular on a closed interval, it can be used for functions with an
!   integrable singularity at one or both of the endpoints.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Note that an integral of a function on an infinite interval can be
!   converted to an integral on a finite interval by means of a suitable
!   change of variable.  Example (here the notation "inf" means infinity):

!   Int_0^inf f(t) dt  =  Int_0^1 f(t) dt + Int_1^inf f(t) dt
!                      =  Int_0^1 f(t) dt + Int_0^1 f(1/t)/t^2 dt

!   Inputs set in parameter statement below:
!   kdebug Debug level setting.  Default = 2.
!   ndp    Digits of precision.  May not exceed mpipl in file mpmod90.f.
!            In some cases, ndp must be significantly greater than the desired
!            tolerance in the result-- see the examples below.
!   neps   Log10 of the desired tolerance in the result (negative integer).
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!            (possibly doubles) the number of accurate digits in the result,
!            but also roughly quadruples the run time.  nq1 > 2.
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!            default it is set to 8 * 2^nq1.  Increase nq2 if directed by a
!            message produced in initqts.  Note that the dimension of the
!            wk and xk arrays starts with -1, so the length of these arrays is
!            (nq2+2) * 4 eight-byte words.

use qdmodule
use quadglobal
implicit none
integer i, kdebug, ndp, neps, nq1, nq2, n1
parameter (kdebug = 2, ndp = 64, neps = -64, nq1 = 8, nq2 = 8 * 2 ** nq1)
double precision dplog10q, d1, d2, second, tm0, tm1
type (qd_real) err, quadtsq, fun01, fun02, fun03, fun04, fun05, fun06, fun07, &
  fun08, fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, &
  t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2), x1, x2, gammax
external quadtsq, fun01, fun02, fun03, fun04, fun05, fun06, fun07, fun08, &
  fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, second, gammax
integer*4 old_cw

call f_fpu_fix_start (old_cw)

ndebug = kdebug
ndigits = ndp
nerror = 0
nquadl = nq1
write (6, 1) ndigits, neps, nquadl
1 format ('Quadtsq test'/'Digits =',i6,'  Epsilon =',i6,'   Quadlevel =',i6)

!   Initialize quadrature tables wk and xk (weights and abscissas).

tm0 = second ()
call initqtsq (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite itervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun01, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call qdwrite (6, t1)
t2 = 0.25d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun02, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = (qdpi() - 2.d0 + 2.d0 * log (qdreal (2.d0))) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadtsq (fun03, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * (exp (0.5d0 * qdpi()) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun04, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 5.d0 * qdpi()**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 15)
15 format (/&
  'Continuous functions on finite itervals, but non-diff at an endpoint'// &
  'Problem 5: Int_0^1 sqrt(t)*log(t) dt = -4/9')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun05, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = qdreal (-4.d0) / 9.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 16)
16 format (/'Problem 6: Int_0^1 sqrt(1-t^2) dt = pi/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun06, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.25d0 * qdpi()
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 17)
17 format (/&
  'Functions on finite intervals with integrable singularity at an endpoint.'//&
  'Problem 7: Int_0^1 sqrt(t)/sqrt(1-t^2) dt = 2*sqrt(pi)*gamma(3/4)/gamma(1/4)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun07, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 2.d0 * sqrt (qdpi()) * gammax (qdreal (0.75d0)) / gammax (qdreal (0.25d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 18)
18 format (/'Problem 8: Int_0^1 log(t)^2 dt = 2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun08, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 2.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 19)
19 format (/'Problem 9: Int_0^(pi/2) log(cos(t)) dt = -pi*log(2)/2')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadtsq (fun09, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = -0.5d0 * qdpi() * log (qdreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 20)
20 format (/'Problem 10: Int_0^(pi/2) sqrt(tan(t)) dt = pi*sqrt(2)/2')
x1 = 0.d0
x2 = 0.5d0 * qdpi()
tm0 = second ()
t1 = quadtsq (fun10, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * qdpi() * sqrt (qdreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 21)
21 format (/&
  'Functions on an infinite interval (requiring a two-step solution'//&
  'Problem 11: Int_0^inf 1/(1+t^2) dt = pi/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun11, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0 * qdpi()
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 22)
22 format (/'Problem 12: Int_0^inf e^(-t)/sqrt(t) dt = sqrt(pi)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun12, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = sqrt (qdpi())
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 23)
23 format (/'Problem 13: Int_0^inf e^(-t^2/2) dt = sqrt(pi/2)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun13, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = sqrt (0.5d0 * qdpi())
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 24)
24 format (/&
  'Oscillatory functions on an infinite interval.'//&
  'Problem 14: Int_0^inf e^(-t)*cos(t) dt = 1/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadtsq (fun14, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
t2 = 0.5d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/'Problem 15: Int_0^inf sin(t)/t = pi/2')
x1 = 0.d0
x2 = qdpi()
tm0 = second ()
t1 = quadtsq (fun15a, x1, x2, nq1, nq2, wk, xk)
x2 = 1.d0 / qdpi()
t2 = quadtsq (fun15b, x1, x2, nq1, nq2, wk, xk)
t3 = t1 + 40320.d0 * t2 - 1.d0 / qdpi() + 2.d0 / qdpi() ** 3 &
  - 24.d0 / qdpi() ** 5 + 720.d0 / qdpi() ** 7
tm1 = second ()
write (6, 3) tm1 - tm0
t4 = 0.5d0 * qdpi()
call decmdq (t4 - t3, d1, n1)
write (6, 4) d1, n1
write (6, 26)
26 format ('Prob 15 error may be 40,000 X higher than estimated error.')

call f_fpu_fix_end (old_cw)
stop
end

function fun01 (t)

!   fun01(t) = t * log(1+t)

use qdmodule
implicit none
type (qd_real) fun01, t

fun01 = t * log (1.d0 + t)
return
end

function fun02 (t)

!   fun02(t) = t^2 * arctan(t)

use qdmodule
implicit none
type (qd_real) fun02, t

fun02 = t ** 2 * atan (t)
return
end

function fun03 (t)

!   fun03(t) = e^t * cos(t)

use qdmodule
implicit none
type (qd_real) fun03, t

fun03 = exp(t) * cos(t)
return
end

function fun04 (t)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use qdmodule
implicit none
type (qd_real) fun04, t, t1

t1 = sqrt (2.d0 + t**2)
fun04 = atan(t1)/((1.d0 + t**2)*t1)
return
end

function fun05 (t)

!    fun05(t) = sqrt(t)*log(t)

use qdmodule
implicit none
type (qd_real) fun05, t

fun05 = sqrt (t) * log (t)
return
end

function fun06 (t)

!    fun06(t) = sqrt(1-t^2)

use qdmodule
implicit none
type (qd_real) fun06, t

fun06 = sqrt (1.d0 - t**2)
return
end

function fun07 (t)

!   fun07(t) = sqrt(t) / sqrt(1-t^2)

use qdmodule
implicit none
type (qd_real) fun07, t

fun07 = sqrt (t) / sqrt (1.d0 - t**2)
return
end

function fun08 (t)

!   fun08(t) = log(t)^2

use qdmodule
implicit none
type (qd_real) fun08, t

fun08 = log (t) ** 2
return
end

function fun09 (t)

!   fun09(t) = log (cos (t))

use qdmodule
implicit none
type (qd_real) fun09, t

fun09 = log (cos (t))
return
end

function fun10 (t)

!   fun10(t) = sqrt(tan(t))

use qdmodule
implicit none
type (qd_real) fun10, t

fun10 = sqrt (tan (t))
return
end

function fun11 (t)

!   fun11(t) = 1/(u^2(1+(1/u-1)^2)) = 1/(1 - 2*u + u^2)

use qdmodule
implicit none
type (qd_real) fun11, t

fun11 = 1.d0 / (1.d0 - 2.d0 * t + 2.d0 * t ** 2)
return
end

function fun12 (t)

!   fun12(t) = e^(-(1/t-1)) / sqrt(t^3 - t^4)

use qdmodule
implicit none
type (qd_real) fun12, t, t1

t1 = 1.d0 / t - 1.d0
fun12 = exp (-t1) / sqrt (t ** 3 - t ** 4)
return
end

function fun13 (t)

!   fun13(t) = e^(-(1/t-1)^2/2) / t^2

use qdmodule
implicit none
type (qd_real) fun13, t, t1

t1 = 1.d0 / t - 1.d0
fun13 = exp (-0.5d0 * t1 ** 2) / t ** 2
return
end

function fun14 (t)

!   fun14(t) = e^(-(1/t-1)) * cos (1/t-1) / t^2

use qdmodule
implicit none
type (qd_real) fun14, t, t1

t1 = 1.d0 / t - 1.d0
fun14 = exp (-t1) * cos (t1) / t ** 2
return
end

function fun15a (t)

!   fun15a(t) = sin(t)/t

use qdmodule
use quadglobal
implicit none
type (qd_real) fun15a, t

fun15a = sin (t) / t
return
end

function fun15b (t)

!   fun15b(t) = t^7 * sin(1/t)

use qdmodule
use quadglobal
implicit none
type (qd_real) fun15b, t

if (abs (t) > 1.d-10) then
  fun15b = t**7 * sin (1.d0 / t)
else
  fun15b = 0.d0
endif
return
end

subroutine initqtsq (nq1, nq2, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk using the
!   function x(t) = tanh (pi/2*sinh(t)).  The argument nq2 is the space
!   allocated for wk and xk in the calling program.  By default it is set to
!   8 * 2^nq1.  Increase nq2 if directed by a message produced below.
!   Upon completion, wk(-1) = nq1, and xk(-1) = n, the maximum space parameter
!   for these arrays.  In other words, the arrays occupy (wk(i), i = -1 to n)
!   and (xk(i), i = -1 to n), where n = xk(-1).  The array x_k contains
!   1 minus the abscissas; the wk array contains the weights at these abscissas.

!   David H Bailey    2004-07-28

use qdmodule
use quadglobal
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2
real*8 eps, h
parameter (iprint = 1000)
type (qd_real) p2, t1, t2, t3, t4, t5, u1, u2, wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqtsq: Tanh-sinh quadrature initialization')
endif

eps = 1.d-64
p2 = 0.5d0 * qdpi()
h = 0.5d0 ** nq1
wk(-1) = dble (nq1)

do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, nq2
  t1 = dble (k) * h

!   xk(k) = 1 - tanh (u1) = 1 /(e^u1 * cosh (u1))
!   wk(k) = u2 / cosh (u1)^2
!   where u1 = pi/2 * cosh (t1), u2 = pi/2 * sinh (t1)

  t2 = exp (t1)
  u1 = 0.5d0 * p2 * (t2 + 1.d0 / t2)
  u2 = 0.5d0 * p2 * (t2 - 1.d0 / t2)
  t3 = exp (u2)
  t4 = 0.5d0 * (t3 + 1.d0 / t3)
  xk(k) = 1.d0 / (t3 * t4)
  wk(k) = u1 / t4 ** 2
  if (wk(k) < eps) goto 100
enddo

write (6, 2) nq2
2 format ('initqtsq: Table space parameter is too small; value =',i8)
nerror = 91
goto 130

100 continue

xk(-1) = dble (k)
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqtsq: Table spaced used =',i8)
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqtsq: Error in quadrature initialization; code =',i5)

130  continue

return
end

function quadtsq (fun, x1, x2, nq1, nq2, wk, xk)

!   This routine computes the integral of the function in fun on the interval
!   [x1, x2], with up to nq1 iterations, with a target tolerance of eps.
!   wk and xk are precomputed tables of weights and abscissas.  The function
!   fun is not evaluated at x = x1 or x2.  The array x_k contains 1 minus
!   the abscissas; the wk array contains the weights at these abscissas.

!   David H. Bailey     2004-07-28

use qdmodule
use quadglobal
implicit none
integer i, ierror, ip(0:100), iz1, iz2, izx, j, k, k1, k2, n, nds, nq1, nq2, &
  nqq1
parameter (izx = 4)
logical log1, log2
real*8 d1, d2, d3, d4, dplog10q, h
type (qd_real) ax, bx, c10, quadtsq, eps, eps1, eps2, err, fun, &
  tsum, s1, s2, s3, t1, t2, t3, t4, tw1, tw2, twi1, twi2, twmx, &
  wk(-1:nq2), xk(-1:nq2), x1, x2, xki, xt1, xx1, xx2
external fun, dplog10q

ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
tsum = 0.d0
s1 = 0.d0
s2 = 0.d0
h = 1.d0
c10 = 10.d0
eps = 1.d-64

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadtsq: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 140
endif
nqq1 = dble (wk(-1))
n = dble (xk(-1))

do k = 0, nqq1
  ip(k) = 2 ** k
enddo

do k = 1, nq1
  h = 0.5d0 * h
  s3 = s2
  s2 = s1
  k1 = ip(nqq1-k)
  k2 = ip(nqq1-k+1)
  iz1 = 0
  iz2 = 0
  twmx = 0.d0

!   Evaluate function at level k in x, avoiding unnecessary computation.

  do i = 0, n, k1
    if (mod (i, k2) /= 0 .or. k == 1) then
      xki = xk(i)
      xt1 = 1.d0 - xki
      xx1 = - ax * xt1 + bx
      xx2 = ax * xt1 + bx
      log1 = xx1 > x1
      log2 = xx2 < x2

      if (log1 .and. iz1 < izx) then
        t1 = fun (xx1)
        tw1 = t1 * wk(i)
        twi1 = abs (tw1)
        if (twi1 < eps) then
          iz1 = iz1 + 1
        else
          iz1 = 0
        endif
      else
        t1 = 0.d0
        tw1 = 0.d0
      endif

      if (i > 0 .and. log2 .and. iz2 < izx) then
        t2 = fun (xx2)
        tw2 = t2 * wk(i)
        twi2 = abs (tw2)
        if (twi2 < eps) then
          iz2 = iz2 + 1
        else
          iz2 = 0
        endif
      else
        t2 = 0.d0
        tw2 = 0.d0
      endif

      tsum = tsum + tw1 + tw2
      twmx = max (twmx, abs (tw1), abs (tw2))
    endif
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.
!   Twi1 and twi2 are the final nonzero values of abs(tw1) and abs(tw2).

  s1 =  ax * h * tsum
  eps1 = twmx * eps
  eps2 = max (twi1, twi2)
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0
  d4 = dplog10q (eps2) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    err = c10 ** nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3, d4)))
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadtsq: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
    call qdwrite (6, s1)
  endif
  if (k >= 3 .and. err < eps1) goto 140
  if (k >= 3 .and. err < eps2) goto 120
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadtsq: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
goto 140

120 continue

write (6, 4) nint (dplog10q (abs (err))), ndigits
4 format ('quadtsq: Estimated error = 10^',i5/&
  'Increase working prec (Digits) for greater accuracy. Current Digits =',i4)
goto 140

130 continue

if (ierror > 0) nerror = ierror + 100
write (6, 5) nerror
5 format ('quadtsq: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quadtsq = s1
return
end

function gammax (t)

!   This evaluates the gamma function, using an algorithm of R. W. Potter.

use qdmodule
implicit none
integer i, j, k, ndp, neps, nt, nwords
double precision alpha, con1, con2, d1, d2
parameter (con1 = 1.151292547d0, con2 = 1.974476770d0)
type (qd_real) eps, gammax, sum1, sum2, t, t1, t2, t3, t4, z

neps = -64
ndp = 64
eps = 1d-64

!   Handle special arguments.

if (abs (t) > 170.d0) then
  write (6, *) 'gamma: argument too large'
  goto 120
elseif (t == anint (t)) then
  if (t <= 0.d0) then
    write (6, *) 'gamma: invalid negative argument'
    z = 0.d0
    goto 120
  endif
  nt = dble (t)
  t1 = 1.d0

  do i = 2, nt - 1
    t1 = dble (i) * t1
  enddo

  z = t1
  goto 120
endif

!   Calculate alpha, then take the next highest integer value, so that
!   d2 = 0.25 * alpha^2 can be calculated exactly in double precision.

alpha = aint (con1 * ndp + 1.d0)
t1 = t
d2 = 0.25d0 * alpha**2
t3 = 1.d0 / t1
sum1 = t3

!   Evaluate the series with t, terminating when t3 < sum1 * epsilon.

do j = 1, 1000000000
  t3 = t3 * d2 / (dble (j) * (t1 + dble (j)))
  sum1 = sum1 + t3
  if (abs (t3) < abs (sum1) * eps) goto 100
enddo

write (6, *) 'gamma: loop overflow 1'
sum1 = 0.d0

100 continue

sum1 = t1 * (0.5d0 * alpha) ** t1 * sum1
t1 = -t
t3 = 1.d0 / t1
sum2 = t3

!   Evaluate the same series with -t, terminating when t3 < sum1 * epsilon.

do j = 1, 1000000000
  t3 = t3 * d2 / (dble (j) * (t1 + dble (j)))
  sum2 = sum2 + t3
  if (abs (t3) < abs (sum2) * eps) goto 110
enddo

write (6, *) 'gamma: loop overflow 2'
sum2 = 0.d0

110 continue

sum2 = t1 * (0.5d0 * alpha) ** t1 * sum2

!   Conclude with this square root expression.

z = sqrt (qdpi() * sum1 / (t * sin (qdpi() * t) * sum2))

120 continue

gammax = z
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use qdmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (qd_real) a

da = a
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da))
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use qdmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (qd_real) a

da = a
if (da .ne. 0.d0) then
  t1 = log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


!Definicion de la funcion a Evaluar
Real *8 Function f (x) !Declaracion
  Implicit None
  Real*8 :: x !Variables que se obtienen
  f =exp(-x*x/2) !funcion
end Function f
!
!Empieza Programa MAIN
Program ActI

  !Definicion de Variables
  Implicit None
  Real *8 :: f               !Funcion
  Real *8 :: x0              !Punto de interes
  Real *8 :: xi , xf, y, z   !Rango de valoración
  Real *4 :: k = 0.1         !Incrementos

  !Pedir Info a User
  Write(*,*) "==================================================="
  Write(*,*) "La función a Evaluar es exp(-x**2/2)"
  Write(*,*) "==================================================="
  Write(*,*) "Punto de Interes x0 a Evaluar"
  Read(*,*) x0

  !Evaluando Funcion en x0 e imprimeiendo en pantalla
  Write(*,*) "exp(-x**2/2) evaluado en", real(x0), "es" , f(x0)
 ! Write(*,*) "==================================================="

  !Calculo en un rango dado
  Write(*,*) "Rango de Medicion, Limite Inferior-Limite Superior"
  Read(*,*)  xi , xf

  if (xi > xf) then !Checar el orden de los limites
     Write(*,*) "Escribiste los limites en el orden incorrecto. Corrigiendo"
     z=xi
     xi=xf       !Reacomodo de los Limites
     xf=z
  end if

  !Abriendo documento para escribir salida
  Open(1, file="Dat.dat")

  do while (xi <= xf+k)
     y = f(xi)
     Write(1,*) xi, y
     xi =xi + k
  end do

  Close(1)
  Write(*,*) "Fin del Calculo"

End Program ActI


module paraboloid
    implicit none

contains
    function paraf(x)
        double precision, intent(in) :: x(:)
        double precision             :: paraf

        double precision :: x1, x2

        x1 = x(1)
        x2 = x(2)

        paraf = x1*x1 + x2*x2
    end function paraf

    subroutine parag(gx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: gx(:)

        double precision :: x1, x2

        x1 = x(1)
        x2 = x(2)

        gx(1) = 2*x1
        gx(2) = 2*x2
    end subroutine parag

    subroutine parah(hx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: hx(:, :)

        double precision :: x1, x2

        x1 = x(1)
        x2 = x(2)

        hx(1, 1) = 2
        hx(1, 2) = 0
        hx(2, 1) = 0
        hx(2, 2) = 2
    end subroutine parah
end module paraboloid


!!# FUNCTION MODULE: <<FUN_xyANGLE>>
MODULE FUN_xyANGLE

!!## PURPOSE
!! Calculate the angle between two vectors $\theta \in [0,2\pi]$.

!!## MODULE DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: &                !!((01-A-KND_IntrinsicTypes.f90))
  KIND_Rsp,KIND_Rdp

USE PAR_Constants_Rsp ,ONLY: &                !!((02-A-PAR_Constants_Rsp.f90))
  c_0_Rsp           => c_0          , &
  c_1_Rsp           => c_1          , &
  c_2_times_PI_Rsp  => c_2_times_PI , &
  c_180_by_PI_Rsp   => c_180_by_PI

USE PAR_Constants_Rdp,ONLY: &                 !!((02-A-PAR_Constants_Rdp.f90))
  c_0_Rdp            => c_0          , &
  c_1_Rdp            => c_1          , &
  c_2_times_PI_Rdp   => c_2_times_PI , &
  c_180_by_PI_Rdp    => c_180_by_PI

USE FUN_xyDOT      ,ONLY: xyDOT_VV            !!((03-A-FUN_xyDOT.f90))
USE FUN_xyDIRECTION,ONLY: xyDIRECTION_V       !!((04-B-FUN_xyDIRECTION.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyANGLE_VV
 MODULE PROCEDURE xyANGLE_VV_Rsp
 MODULE PROCEDURE xyANGLE_VV_Rdp
END INTERFACE

INTERFACE xyANGLE_UU
 MODULE PROCEDURE xyANGLE_UU_Rsp
 MODULE PROCEDURE xyANGLE_UU_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyANGLE_VV
PUBLIC :: xyANGLE_UU

!!## CONTAINED PROCEDURES
CONTAINS

!!### PURE FUNCTION: <<xyANGLE_UU_Rsp>>
PURE FUNCTION xyANGLE_UU_Rsp( U_a , U_b ) RESULT(t)

!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),PARAMETER :: c_2_times_PI = c_2_times_PI_Rsp
INCLUDE "05-B-FUN_xyANGLE_UU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyANGLE_UU.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <<xyANGLE_UU_Rdp>>
PURE FUNCTION xyANGLE_UU_Rdp( U_a , U_b ) RESULT(t)

!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),PARAMETER :: c_2_times_PI = c_2_times_PI_Rdp
INCLUDE "05-B-FUN_xyANGLE_UU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyANGLE_UU.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <<xyANGLE_VV_Rsp>>
PURE FUNCTION xyANGLE_VV_Rsp( V_a , V_b ) RESULT(t)

!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyANGLE_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyANGLE_VV.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <<xyANGLE_VV_Rdp>>
PURE FUNCTION xyANGLE_VV_Rdp( V_a , V_b ) RESULT(t)

!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyANGLE_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyANGLE_VV.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!--------------------------------------------------------------------------------------------------
! MODULE: assignment_problem_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date March, 2017
!
!> @brief Subroutine for solving the assignment problem.
!> @details
!! The (linear) assignment problem:
!!
!! The problem consists of n agents and n tasks. Any agent can be assigned to perform any task,
!! incurring a cost depending on the agent-task assignment. It is required to perform all tasks
!! by assigning exactly one agent to each task and exactly one task to each agent in such a way
!! that the total cost (sum of agent-task costs) of the assignment is minimized.
!!
!! A modified form of the Hungarian method (Kuhn–Munkres algorithm) is used.
!! Adapted from: http://csclab.murraystate.edu/~bob.pilgrim/445/munkres.html
!!
!! References:
!! J. Munkres, "Algorithms for the Assignment and Transportation Problems", J. SIAM, 5(1),
!!              32–38, 1957 March.
!--------------------------------------------------------------------------------------------------
module assignment_problem_mod
    use global_defs
    implicit none

    private
    public :: assignment_problem
    public :: getloops
    public :: getloop

    real(dp), parameter :: tinydp = 1.e-15_dp

    integer :: m
    integer :: n
    integer :: k
    real(dp), allocatable :: cm(:, :)
    logical, allocatable :: zmat(:, :)
    logical, allocatable :: rowc(:)
    logical, allocatable :: colc(:)
    logical, allocatable :: star(:, :)
    logical, allocatable :: prim(:, :)
    integer :: cpos(2)
    integer :: step

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: assignment_problem
    !
    !> @brief The Kuhn-Munkres algorithm for square matrices.
    !> @details
    !! Input is a real matrix with dimensions n x n. The output is a vector containing the optimal
    !! permutation of columns associated to each row of the matrix (e. g. element 1 of the vector
    !! is the column associated with row 1 of the matrix).
    !!
    !! The algorithm is split into steps, each contained in a separate helper subroutine.
    !----------------------------------------------------------------------------------------------
    subroutine assignment_problem(matrix, assigned_rows, assigned_cols)
        real(dp), intent(in) :: matrix(:, :)
        integer, allocatable, intent(out) :: assigned_rows(:)
        integer, allocatable, intent(out) :: assigned_cols(:)

        if (size(matrix, 1) > size(matrix, 2)) then
            allocate(cm, source=transpose(matrix))
        else
            allocate(cm, source=matrix)
        end if
        m = size(cm, 1)
        n = size(cm, 2)
        k = min(m, n)
        allocate(zmat(m, n))
        allocate(star(m, n))
        allocate(prim(m, n))
        allocate(rowc(m))
        allocate(colc(n))
        if (.not. allocated(assigned_rows)) allocate(assigned_rows(k))
        if (.not. allocated(assigned_cols)) allocate(assigned_cols(k))

        step = 1
        colc = .false.
        rowc = .false.
        prim = .false.
        star = .false.
        do
            select case(step)
            case(1)
                call step1()
            case(2)
                call step2()
            case(3)
                call step3()
            case(4)
                call step4()
            case(5)
                call step5()
            case(6)
                call step6()
            case(7)
                if (size(matrix, 1) /= m) then
                    call step7(transpose(star), assigned_rows, assigned_cols)
                else
                    call step7(star, assigned_rows, assigned_cols)
                end if
                exit
            end select
        end do

        deallocate(cm)
        deallocate(zmat)
        deallocate(star)
        deallocate(prim)
        deallocate(rowc)
        deallocate(colc)
    end subroutine assignment_problem

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step1
    !
    !> @details
    !! For each row of the matrix, find the smallest element and subtract it from every element in
    !! its row. Repeat for columns. Create a logical matrix which is .true. where the value of the
    !! input matrix is zero. Go to Step 2.
    !----------------------------------------------------------------------------------------------
    subroutine step1()
        integer :: i
        do i = 1, m
            cm(i, :) = cm(i, :) - minval(cm(i, :))
        end do
        zmat = (cm < tinydp)
        step = 2
    end subroutine step1

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step2
    !
    !> @details
    !! Cycle through the zeroes. If there is no starred zero in the row or column of a zero, star
    !! it. Go to Step 3.
    !----------------------------------------------------------------------------------------------
    subroutine step2()
        integer :: i, j
        star = .false.
        do i = 1, m
            if (any(star(i, :))) cycle
            do j = 1, n
                if (.not. zmat(i, j)) cycle
                if (any(star(:, j))) cycle
                star(i, j) = .true.
                exit
            end do
        end do
        step = 3
    end subroutine step2

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step3
    !
    !> @details
    !! Cover each column containing a starred zero. If k columns are covered, the starred zeros
    !! describe a complete set of unique assignments (go to step 7). If not, go to step 4.
    !----------------------------------------------------------------------------------------------
    subroutine step3()
        integer :: j, c

        c = 0
        do j = 1, n
            if (.not. any(star(:, j))) cycle
            colc(j) = .true.
            c = c + 1
        end do

        if (c == k) then
            step = 7
        else
            step = 4
        end if
    end subroutine step3

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step4
    !
    !> @details
    !! Find a noncovered zero and prime it.  If there is no starred zero in the row containing the
    !! primed zero, mark the position of the primed zero and Go to Step 5.  Otherwise, cover this
    !! row and uncover the column containing the starred zero. Repeat. If there are no uncovered
    !! zeros left, go to Step 6.
    !----------------------------------------------------------------------------------------------
    subroutine step4()
        integer :: i, j
        logical :: starincol

        do
            cpos = [0, 0]
            starincol = .false.
outer:      do i = 1, m
                if (rowc(i)) cycle
inner:          do j = 1, n
                    if (colc(j)) cycle
                    if (.not. zmat(i, j)) cycle
                    prim(i, j) = .true.
                    cpos = [i, j]
                    exit outer
                end do inner
            end do outer
            if (cpos(1) == 0) then
                step = 6
                return
            end if
            do j = 1, n
                if (.not. star(cpos(1), j)) cycle
                colc(j) = .false.
                rowc(cpos(1)) = .true.
                starincol = .true.
            end do
            if (.not. starincol) then
                step = 5
                return
            end if
        end do

    end subroutine step4

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step5
    !
    !> @details
    !! Starting at the final primed zero of Step 4, move through the matrix in the following way:
    !! Go to a starred zero in the same column as the primed zero (if possible). Go to a primed
    !! zero in the same row as the starred zero (always possible). Along the way, unstar all
    !! starred zeros and star all primed zeros. When no starred zeros are present in the column of
    !! a primed zero, uncover all lines of the matrix, unprime all zeros and go to Step 3.
    !----------------------------------------------------------------------------------------------
    subroutine step5()
        integer :: i, j
        logical :: starincol

        do
            starincol = .false.
            do i = 1, m
                if (.not. star(i, cpos(2))) cycle
                starincol = .true.
                star(cpos(1), cpos(2)) = .true.
                cpos(1) = i
                exit
            end do
            if (.not. starincol) then
                star(cpos(1), cpos(2)) = .true.
                prim = .false.
                rowc = .false.
                colc = .false.
                step = 3
                return
            end if
            do j = 1, n
                if (.not. prim(cpos(1), j)) cycle
                star(cpos(1), cpos(2)) = .false.
                cpos(2) = j
                exit
            end do
        end do
    end subroutine step5

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step6
    !
    !> @details
    !! Find the smallest uncovered value. Add this value to every element of each covered row, and
    !! subtract it from every element of each uncovered column. Return to Step 4.
    !----------------------------------------------------------------------------------------------
    subroutine step6()
        real(dp) :: mval
        logical :: mask(m, n)
        integer :: i, j

        mask = .true.
        do i = 1, m
            if (rowc(i)) mask(i, :) = .false.
        end do
        do j = 1, n
            if (colc(j)) mask(:, j) = .false.
        end do
        mval = minval(cm, mask)
        do i = 1, m
            if (rowc(i)) cm(i, :) = cm(i, :) + mval
        end do
        do j = 1, n
            if (.not. colc(j)) cm(:, j) = cm(:, j) - mval
        end do
        zmat = (cm < tinydp)
        step = 4
    end subroutine step6

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: Step7
    !
    !> @details
    !! Construct the output vector from the matrix of starred zeros.
    !----------------------------------------------------------------------------------------------
    subroutine step7(solution, assigned_rows, assigned_cols)
        logical, intent(in) :: solution(:, :)
        integer, intent(out) :: assigned_rows(:)
        integer, intent(out) :: assigned_cols(:)
        integer :: i, j, c

        c = 0
        do i = 1, size(solution, 1)
            do j = 1, size(solution, 2)
                if (solution(i, j)) then
                    c = c + 1
                    assigned_rows(c) = i
                    assigned_cols(c) = j
                end if
            end do
        end do
    end subroutine step7

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: GetLoops
    !> @brief Find all loops in given list of indexes.
    !----------------------------------------------------------------------------------------------
    subroutine getloops(list, loops)
        use ivec_mod
        integer, intent(in) :: list(:)
        type(ivec), allocatable, intent(out) :: loops(:)
        type(ivec) :: tmp(size(list))
        logical :: mask(size(list))
        integer :: i, n

        mask = .true.
        n = 0
        do i = 1, size(list)
            if (.not. mask(i)) cycle
            n = n + 1
            call getloop(list, i, tmp(n)%c, mask)
        end do

        if (allocated(loops)) deallocate(loops)
        allocate(loops(n))
        do i = 1, n
            loops(i) = tmp(i)
        end do
    end subroutine getloops

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: GetLoop
    !> @brief Follow list of indexes until it loops to initial index.
    !----------------------------------------------------------------------------------------------
    subroutine getloop(list, init, loop, mask)
        integer, intent(in) :: list(:) !< List of indexes to follow.
        integer, intent(in) :: init !< Initial position in list.
        integer, allocatable, intent(out) :: loop(:) !< List of indexes until init is found.
        logical :: mask(size(list))
        integer :: i, n

        n = 1
        i = init
        getn: do
            mask(i) = .false.
            if (list(i) == init) exit getn
            i = list(i)
            n = n + 1
            if (i > size(list)) then
                write(stderr, *) 'Error in getloop subroutine. Index out of bounds.'
                call abort()
            end if
            if (n > size(list)) then
                write(stderr, *) 'Error in getloop subroutine. Bad input list.'
                call abort()
            end if
        end do getn

        if (allocated(loop)) deallocate(loop)
        allocate(loop(n))
        i = init
        fill: do n = 1, size(loop)
            loop(n) = i
            if (list(i) == init) exit fill
            i = list(i)
        end do fill
    end subroutine getloop

end module assignment_problem_mod


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

!> geometry module
module modGeometry
  public

  ! constants
  integer,private,parameter::DIMS=3 !< dimensions

  ! long operations are interfaced
  interface
  end interface

contains

  !> find the area of a triangle
  pure function a3p(p)
    double precision,intent(in)::p(DIMS,3) !< positions of the 3 vertices
    double precision a3p !< area of the triangle
    double precision a(DIMS),b(DIMS)

    a(:)=p(:,2)-p(:,1)
    b(:)=p(:,3)-p(:,1)
    a3p=((a(2)*b(3)-a(3)*b(2))**2d0&
    &   +(a(3)*b(1)-a(1)*b(3))**2d0&
    &   +(a(1)*b(2)-a(2)*b(1))**2d0)**0.5d0/2d0
  end function

  !> find the area of a quadrilateral
  pure function a4p(p)
    double precision,intent(in)::p(DIMS,4) !< positions of the 4 vertices
    double precision a4p !< area of the triangle

    a4p=a3p(p(:,[1,2,3]))+a3p(p(:,[3,4,1]))
  end function

  !> find the normal vector of a triangle
  pure function n3p(p)
    double precision,intent(in)::p(DIMS,3) !< positions of the 3 vertices
    double precision n3p(DIMS) !< normal vector of the triangle
    double precision a(DIMS),b(DIMS),c(DIMS)

    a(:)=p(:,2)-p(:,1)
    b(:)=p(:,3)-p(:,2)
    c(1)=a(2)*b(3)-a(3)*b(2)
    c(2)=a(3)*b(1)-a(1)*b(3)
    c(3)=a(1)*b(2)-a(2)*b(1)
    n3p(:)=c(:)/norm2(c)
  end function

  !> find the normal vector of a quadrilateral
  pure function n4p(p)
    double precision,intent(in)::p(DIMS,4) !< positions of the 4 vertices
    double precision n4p(DIMS) !< normal vector of the quadrilateral

    n4p(:)=n3p(p(:,[1,2,3]))+n3p(p(:,[3,4,1]))
    n4p(:)=n4p(:)/norm2(n4p)
  end function

  !> find the volume of a tetrahedron
  pure function v4p(p)
    double precision,intent(in)::p(DIMS,4) !< positions of the 4 vertices
    double precision v4p !< volume of the tetrahedron
    double precision y1z2,y1z3,y1z4,y2z1,y2z3,y2z4,y3z1,y3z2,y3z4,y4z1,y4z2,y4z3

    y1z2=p(2,1)*p(3,2)
    y1z3=p(2,1)*p(3,3)
    y1z4=p(2,1)*p(3,4)
    y2z1=p(2,2)*p(3,1)
    y2z3=p(2,2)*p(3,3)
    y2z4=p(2,2)*p(3,4)
    y3z1=p(2,3)*p(3,1)
    y3z2=p(2,3)*p(3,2)
    y3z4=p(2,3)*p(3,4)
    y4z1=p(2,4)*p(3,1)
    y4z2=p(2,4)*p(3,2)
    y4z3=p(2,4)*p(3,3)
    v4p=abs((p(1,2)*(y3z4-y4z3)-p(1,3)*(y2z4-y4z2)+p(1,4)*(y2z3-y3z2))&
    &      -(p(1,1)*(y3z4-y4z3)-p(1,3)*(y1z4-y4z1)+p(1,4)*(y1z3-y3z1))&
    &      +(p(1,1)*(y2z4-y4z2)-p(1,2)*(y1z4-y4z1)+p(1,4)*(y1z2-y2z1))&
    &      -(p(1,1)*(y2z3-y3z2)-p(1,2)*(y1z3-y3z1)+p(1,3)*(y1z2-y2z1)))/6d0
  end function

  !> find the volume of a hexahedron
  pure function v8p(p)
    double precision,intent(in)::p(DIMS,8) !< positions of the 8 vertices
    double precision v8p !< volume of the tetrahedron

    v8p=v4p(p(:,[1,2,3,6]))+v4p(p(:,[1,3,4,6]))+v4p(p(:,[1,4,5,6]))&
    &  +v4p(p(:,[4,5,6,7]))+v4p(p(:,[3,4,6,7]))+v4p(p(:,[4,5,7,8]))
  end function

end module


use, intrinsic:: ieee_arithmetic
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit, sp=>real32, dp=>real64, qp=>real128
use fib3, only: fib
use assert, only: wp, isclose, assert_isclose

implicit none

real(wp), parameter :: pi = 4.*atan(1._wp)

real(wp) :: nan, inf

! NOTE: this triggers nuisance exceptions IEEE_INVALID_FLAG, IEEE_OVERFLOW_FLAG
nan = ieee_value(1._wp,ieee_quiet_nan)
inf = ieee_value(1._wp,ieee_positive_inf)
!--------------------------------------------

!------ Assert

if (isclose(-pi, pi)) error stop
call assert_isclose(ieee_next_after(pi,0.), pi, err_msg='very close fail')
call assert_isclose(pi+0.001, pi, rtol=0.001_wp, atol=0.0001_wp, err_msg='tolerance fail')

call assert_isclose(nan, nan,equal_nan=.true., err_msg='NaN request equality fail')
call assert_isclose(nan, -nan,equal_nan=.true., err_msg='+NaN -Nan request equality fail')
if (isclose(nan,nan)) error stop 'non-equal NaN failure'

if (isclose(-inf, inf)) error stop 'assert -inf  +inf inequality fail'

if (isclose(nan,inf)) error stop
if (isclose(inf,nan)) error stop

! denormal
! ifort needs special options to handle these denormal
if (wp==sp.and.isclose(1e-38_wp, 0._wp, atol=0._wp)) write(stderr,*) 'single precision denormal'

if (wp==dp.and.isclose(1e-308_wp, 0._wp, atol=0._wp)) write(stderr,*) 'double precision denormal'
if (wp==qp.and.isclose(1e-4932_wp, 0._wp, atol=0._wp)) write(stderr,*) 'quad precision denormal'
! tiny: 32, 64, 128 bits:
! 1.17549435E-38   2.2250738585072014E-308   3.36210314311209350626267781732175260E-4932

!print*,nan,inf
!-------

!--------- Fibonacci

call assert_isclose(fib(10),[0._wp,1._wp,1._wp,2._wp,3._wp,5._wp,8._wp,13._wp,21._wp,34._wp],err_msg='fibonacci fail')

print *, 'Finite precision: test OK'
end program


module EulerCommon
   implicit none
   integer, parameter :: int64 = selected_int_kind(15)
   integer, parameter :: int32 = selected_int_kind(10)
   integer, parameter :: dp = selected_real_kind(15,307)
   real(dp), parameter :: varphi = 0.5_dp + (0.5_dp)*sqrt(5.0_dp)

contains
   !> check to see if all digits are in the number
   logical function is_pandigital(n)
      integer(kind=int64), intent(in) :: n
      character(9) :: str, digits
      character(1) :: repin, repout
      integer :: i

      write(str,*) n
      digits = '         '
      do i=1,int(log10(real(n))+1)
         write(digits(i:i), *) i
      end do
      repout = ' '

      do i=1,len(trim(digits))
         repin = str(i:i)
         digits = replace_text(digits, repin, repout)
      end do

      is_pandigital = len(trim(digits)) == 0
   end function is_pandigital

   !> replaces text in str with rep
   function replace_text(str, text, rep) result(outs)
      character(*) :: str, text, rep
      character(len=len(str)) :: outs
      integer :: i, nt, nr

      outs = str
      nt = len_trim(text)
      nr = len_trim(rep)
      do
         i = index(outs, text(:nt))
         if (i == 0) exit
         outs = outs(:i-1) // rep(:nr) // outs(i+nt:)
      end do
   end function replace_text

   !> returns true if the two input numbers are permutations of each other
   logical function is_permutation(a,b,n)
      integer(int64), intent(in) :: a, b, n
      character(len=n) :: t1, t2
      character(len=1) :: repin, repout
      integer(int64) :: i

      write(t1,'(i4)') a
      write(t2,'(i4)') b
      repout = ' '

      do i=1,n
         repin = t1(i:i)
         t2 = replace_text(t2, repin, repout)
      end do !- i

      is_permutation = len(trim(t2)) == 0
   end function is_permutation

   !> quick sort function
   recursive subroutine sort(X)
      integer, intent(inout) :: X(:)
      integer :: iq

      if (size(X)>1) then
         iq = partition(X)
         call sort(X(:iq-1))
         call sort(X(iq:))
      endif
   end subroutine sort

   !> helper for sorting
   integer function partition(A) result(marker)
      integer, intent(inout) :: A(:)
      integer :: i, j, temp, x

      marker=0

      x = A(1)
      i = 0
      j = size(A)+1

      do
         j = j-1
         do
            if (A(j) <= x) exit
            j = j - 1
         end do
         i = i+1
         do
            if (A(i) >= x) exit
            i = i+1
         end do

         if (i < j) then
            temp = A(i)
            A(i) = A(j)
            A(j) = temp
         else if (i==j) then
            marker = i+1
            return
         else
            marker = i
            return
         endif
      end do
   end function partition

   !> primality test using 6 complement
   logical function is_prime6(n) result(res)
     integer(int64), intent(in) :: n
     integer(int64) :: x, i

     if (n < 2) then
        res = .false.
        return
     end if

     if (any(n==[2,3])) then
        res = .true.
        return
     end if

     if (mod(n,2)==0 .or. mod(n,3)==0) then
        res = .false.
        return
     end if

     ! test by 6k+/-1 complement
     x = int(sqrt(real(n)))+1
     do i=6,x,6
        if (mod(n,i-1)==0 .or. mod(n,i+1)==0) then
           res = .false.
           return
        end if
     end do

     res = .true.
     return
   end function is_prime6

   !> more efficient is_prime function, adapated from http://stackoverflow.com/a/5694432/1276356
   logical function is_prime(x) result(bool)
      integer(int64), intent(in) :: x
      integer(int64) ::N, i, p, q
      N = 10
      ! test small primes for a match
      if (any(x==small_primes)) then
         bool = .true.
         return
      end if

      ! test small primes for divisbility
      do i=1,N
         p = small_primes(i)
         q = x/p
         if (q < p) then
            bool = .true.
            return
         end if
         if (x == q*p) then
            bool = .false.
            return
         end if
      end do !- i

      ! test other primes
      i = 31_int64
      do
         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 6

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 4

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 2

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 4

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 2

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 4

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 6

         q = x/i
         if (q < i) then
            bool = .true.
            return
         end if
         if (x == q*i) then
            bool = .false.
            return
         end if
         i = i + 2
      end do !-
      bool = .true.
      return
   end function is_prime

   !> returns the next primes above n
   integer(int64) function next_prime(n) result(p)
      integer(int64), intent(in) :: n
      integer(int64) :: st
      ! take care of the only even prime
      if (n==2) then
         p = 3
         return
      end if

      ! starting number should otherwise be odd
      st = merge(n+1, n+2, mod(n,2)==0)

      ! loop through and test primes, using Bertrand's postulate
      do p=st,2*n,2
         if (is_prime(p)) return
      end do !- p
   end function next_prime

   !> generate a logical array indicating if index i is prime or composite
   subroutine prime_sieve(n, p)
      integer(int64), intent(in) :: n
      logical, dimension(n), intent(out) :: p
      integer(int64) :: i, q(5)=[2,3,5,7,11], r

      p(:) = .true.
      p(1) = .false.
      ! start sieve of 11
      do i=1,5
         r=q(i)
         p(r*r:n:r) = .false.
      end do

      r = int(sqrt(real(n)))
      do i=13,r,2
         if (p(i)) then
            p(2*i:n:i) = .false.
         end if
      end do
   end subroutine prime_sieve

  !> find the factors of a number
   subroutine find_factors(n, d)
      integer(int64), intent(in) :: n
      integer(int64), dimension(:), intent(out) :: d
      integer(int64) :: div, next, rest, i

      div  = 2
      next = 3
      rest = n
      i    = 1

      d(:) = 0

      do while (rest /= 1)
         do while (mod(rest, div) == 0)
            d(i) = div
            i = i + 1
            rest = rest / div
         end do
         div = next
         next = next + 2
      end do
   end subroutine find_factors

   !> factorize a number n
   function factor(n) result(factors)
      integer(int64), intent(in) :: n
      integer(int64), dimension(200) :: factors
      integer(int64) :: m, p, e, k

      factors = 0
      if (any(n==[-1,0,1])) return

      m = merge(-n, n, n<0)

      k = 1

      do while (m /= 1)
         p = trial_division(m)
         e = 1
         m = m/p
         do while (mod(n,p) == 0)
            e = e + 1
            m = m/p
         end do
         factors(k) = p
         k = k + 1
      end do
   end function factor

   !> returns the largest divisor of n
   integer(int64) function trial_division(n) result(F)
      integer(int64), intent(in) :: n
      integer(int64), parameter :: dif(8)=[6,4,2,4,2,4,6,2], p(3)=[2,3,5]
      integer(int64) :: i, m

      if (n == 1) then
         F = 1_int64
         return
      end if

      do i=1,3
         if (mod(n,p(i))==0) then
            F = p(i)
            return
         end if
      end do

      m = 7; i = 1
      do while (m < n .and. m*m <= n)
         if (mod(n,m) == 0) then
            F = m
            return
         end if
         m = m + dif(mod(i,8))
         i = i + 1
      end do

      F = n
      return
   end function

   !> returns true if there are not any duplicated entries in the array, false otherwise
   logical function no_dupes(A) result(bool)
      integer(int64), intent(in) :: A(:)
      integer(int64) :: i, k

      do i=1,size(A)
         k = A(i)
         if (any(k == A(i+1:))) then
            bool = .false.
            return
         end if
      end do
      bool = .true.
      return
   end function no_dupes

   !> works for first 70-ish Fibonacci numbers; uses real-precision based computation of analytic solution
   integer(int64) function fibonacci_approx(n) result(F)
      integer(int64), intent(in) :: n
      real(dp), parameter :: sq5_inv = 1.0_dp / sqrt(5.0_dp)
      F = int(sq5_inv * varphi**n + 0.5_dp,int64)
   end function fibonacci_approx

   !> returns the nth fibonacci number by choosing a method (picks fastest by default)
   integer(int64) function fibonacci(n,methOpt) result(F)
      integer(int64), intent(in) :: n
      integer(int64), optional :: methOpt
      integer(int64) :: m

      m = 1_int64
      if (present(methOpt)) m = methOpt

      f = 0_int64

      select case(m)
        case(1)
           F = fibonacci_doubling(n)
        case(2)
           F = fibonacci_matrix(n)
        case(3)
           F = fibonacci_approx(n)
      end select
   end function fibonacci

   !> returns the nth fibonacci number using matrix exponentiation (fast!)
   integer(int64) function fibonacci_matrix(n) result(F)
      integer(int64), intent(in) :: n
      integer(int64), dimension(2,2) :: Q, S
      integer(int64) :: i
      Q = reshape([0, 1, 1, 1], [2,2])
      S = Q
      do i=1,n-1
!~          Q(1,1) = Q(1,1)*S(1,1) + Q(1,2)*S(2,1); Q(1,2) = Q(1,1)*S(1,2) + Q(1,2)*S(2,2)
!~          Q(2,1) = Q(2,1)*S(1,1) + Q(2,2)*S(2,1); Q(2,2) = Q(2,1)*S(1,2) + Q(2,2)*S(2,2)
!~           ! curiously, the above is giving incorrect answers
         Q = matmul(Q,S)
      end do
      F = Q(2,1)
   end function fibonacci_matrix

   !> returns the nth fibonacci number using the fast-doubling method (fastest!)
   integer(int64) function fibonacci_doubling(n) result(F)
      integer(int64), intent(in) :: n
      integer(int64) :: i, a, b, c, d, t
      i = n - 1_int64
      a = 1_int64
      b = 0_int64
      c = 0_int64
      d = 1_int64

      ! test small numbers
      if (n <= 0_int64) then
         F = 0
         return
      end if

      ! iterate through
      do while (i > 0_int64)
         ! need odd numbers
         do while (mod(i,2_int64)==0_int64)
            t = d*(2_int64*c + d)
            c = c*c + d*d
            d = t
            i = i/2_int64
         end do
         t = d*(b + a) + c*b
         a = d*b + c*a
         b = t
         i = i - 1_int64
      end do
      F = a+b
   end function fibonacci_doubling

   !> returns the triangle sequence
   subroutine set_triangle(n, T)
      integer(int64), intent(in) :: n
      integer(int64), dimension(n) :: T
      integer(int64) :: i

      do i=1,n
         T(i) = triangular(i)
      end do
   end subroutine set_triangle

   !> returns the triangular number of n
   integer(int64) function triangular(n) result(s)
      integer(int64), intent(in) :: n
      s = n*(n+1_int64) / 2_int64
   end function triangular

   !> returns the sum of the characters in the string
   integer(int64) function char_sum(str_in) result(T)
      character(len=*), intent(in) :: str_in
      character(len=len(str_in)) :: str
      integer(int64) :: i

      ! ensure the string is uppercase before running char_map
      str = to_upper(str_in)

      T = 0
      do i=1,len(str)
         T = T + char_map(str(i:i))
      end do
   end function char_sum

   !> returns the letter number based on it's position in the alphabet
   integer(int64) function char_map(char) result(T)
      character(len=1), intent(in) :: char
      character(len=26) :: A = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

      T = index(A, char)
   end function char_map

   !> returns the sum of the ascii values of the string
   integer(int64) function ascii_sum(str) result(T)
      character(len=*), intent(in) :: str
      integer(int64) :: i

      T = 0
      do i=1,len(str)
         T = T + iachar(str(i:i))
      end do
   end function ascii_sum

   !> convert string to upper case
   function to_upper(strIn) result(strOut)
      character(len=*), intent(in) :: strIn
      character(len=len(strIn)) :: strOut
      integer(int64) :: i,j

      do i = 1, len(strIn)
         j = iachar(strIn(i:i))
         if (j>= iachar("a") .and. j<=iachar("z") ) then
            strOut(i:i) = achar(iachar(strIn(i:i))-32)
         else
            strOut(i:i) = strIn(i:i)
         end if
      end do
   end function to_upper

   !> find the permutation index
   integer(int64) function kperm(n,m)
      integer(int64), intent(in):: n
      integer(int64), intent(inout), dimension(N):: m
      integer(int64) :: i, max, r, s

      r = N
      kperm = 0

      do while (r > 1_int64)
         s = 1_int64
         max = m(1)
         do i=1,r
            if (m(i) > max) then
               s = i
               max = m(i)
            end if
         end do
         kperm = kperm*r + s - 1_int64
         m(s) = m(r)
         m(r) = max
         r = r - 1_int64
      end do
      return
   end function kperm

   !> find the next permutation depending on the size of M
   subroutine nextPermutation(M)
      integer(int64), dimension(:), intent(inout) :: M
      integer(int64) :: K, J, CJ, Mm, n

      n = size(M,dim=1)

      k = kperm(n,m)

      do j = 2, n
         cj = mod(k, j)
         k = (k - cj) / j
         mm = m(j)
         m(j) = m(cj+1)
         m(cj+1) = mm
      end do
   end subroutine nextPermutation

   !> returns the factorial using either simple loop or log-gamma
   integer(int64) function factorial(n) result(F)
      integer(int64), intent(in) :: n
      integer(int64) :: i

      if (n < 30_int64) then
        F = 1_int64
        do i=1,n
          F = F * i
        end do
      else
         F = nint(exp(gammaln(n+1._dp)))
      end if
   end function factorial

   !> the log-gamma function (in case lgamma(x) isn't available w/ compiler)
   real(dp) function gammaln(n) result(lg)
      real(dp), intent(in) :: n
      real(dp) :: ser, tmp, x, y
      real(dp), parameter :: cof(6) = [76.18009172947146_dp, -86.5053203941677_dp, &
        24.01409824083091_dp, -1.231739572450155_dp, 0.1208650973866179e-2_dp, &
        -0.5395239384953e-5_dp]
      real(dp), parameter :: stp = 2.5066282746310005_dp
      integer :: j

      x = n*n
      y = x
      tmp = x + 5.5_dp
      tmp = (x + 0.5_dp)*log(tmp) - tmp
      ser = 1.000000000190015_dp
      do j=1,6
         y = y + 1.0_dp
         ser = ser + cof(j) / y
      end do !- j
      lg = tmp + log(stp*ser / x)
   end function gammaln

   !> turns an array into a single number--assumes that size(n) <= 19 digits
   integer(int64) function arrayAsNumber(n) result(A)
      integer(int64), intent(in) :: n(:)
      integer(int64) :: i
      A = 0
      do i=size(n),1,-1
         A = A*10_int64 + n(i)
      end do
   end function arrayAsNumber

   !> ensures the array doesn't have tens by shifting them upwards
   !>  useful for simulating big integers with linear arrays
   subroutine checkTensInArray(n,test)
      integer(int64), intent(in) :: n
      integer(int64), intent(inout) :: test(:)
      integer(int64) :: i,k,m

      do i=1,n
         if (test(i) > 9) then
            m = test(i)
            k = int(test(i)*0.1)
            test(i+1) = test(i+1) + k
            test(i) = m - 10_int64*k
         end if
      end do

      test(n:) = 0
   end subroutine checkTensInArray

   !> returns the permutation of M
   subroutine PERMNX(M,D,N,RT)
      integer(int64), intent(in) :: n
      integer(int64), intent(inout) :: RT
      integer(int64), intent(inout), dimension(n) :: m, d
      integer(int64) :: DK,T,K,J,KL
!                          BRANCH TO 2 IF WE ARE IN THE MIDDLE OF THINGS
      if (rt == 0) then
         d(1:n) = 0_int64
      end if

      RT = 0_int64
      j = -1_int64
      KL = 1_int64
      do k=2,n
         dk = d(k)
         if (dk /= kl) then
            rt = 1_int64
            exit
         end if
         d(k) = 0_int64
         j = -j
         kl = k
      end do

      if (rt == 0_int64) return

      d(k) = dk + 1_int64
      dk = d(k)
      if (j /= 1_int64 .and. dk > 2_int64) kl = k - d(k)

      T = m(k)
      m(k) = m(kl)
      m(kl) = t
   end subroutine PERMNX

   !> return the next permutation
   function next_perm_str(str) result(outs)
      character(len=*), intent(in) :: str
      character(len=len(str)) :: outs
      character(len=1) :: swap
      integer(int64) :: i, j

      outs = str

      ! step 1: find highest index such that str(i) < str(i+1)
      i = len(outs) - 1_int64
      do while (i /= 1_int64)
         if (iachar(outs(i:i)) > iachar(outs(i+1:i+1))) exit
         i = i - 1_int64
      end do

      ! step 2: find j>1 such that str(j) > str(i)
      j = len(outs)
      do while (j /= i)
         if (iachar(outs(j:j)) > iachar(outs(i:i))) exit
      end do

      ! step 3: swap str(i) and str(j)
      swap = outs(i:i)
      outs(i:i) = outs(j:j)
      outs(j:j) = swap

      ! step 4: reverse str(i+1) to end
      j = len(outs)
      do while (i /= len(outs))
         outs(i:i) = str(j:j)
         i = i + 1_int64
         j = j - 1_int64
      end do

   end function next_perm_str

   !> count the number of repetitions of the subarray in the array
   integer(int64) function count_repetitions(sub, array) result(num)
      integer(int64), intent(in) :: sub(:), array(:)
      integer(int64) :: ns, na, i
      ns = size(sub); na = size(array)
      num = 0_int64

      do i=1,na
         if (all(sub(:) == array(i:i+ns-1))) num = num + 1_int64
      end do
   end function count_repetitions

   !> count substrings, from https://www.rosettacode.org/wiki/Count_occurrences_of_a_substring#Fortran
   integer(int64) function count_substr(str, sub) result(ctr)
      character(*), intent(in) :: str, sub
      integer(int64) :: ns, na, i
      ns = len(str)
      na = len(sub)
      ctr = 0_int64

      do i=1,ns
         if (sub == str(i:i+na-1)) ctr = ctr + 1_int64
      end do
   end function count_substr

   !> return the number of primes in the string given replacement
   integer(int64) function count_primes(str,d,p_list) result(ctr)
      character(len=*), intent(in) :: str, d
      logical, dimension(:), intent(in) :: p_list
      character(len=10) :: digits='0123456789'
      character(len=len(str)) :: new_str
      integer(int64) :: nd,i,val,nlist,j,ns

      nd = len(d)
      if (nd /= 1_int64) then
         ctr = -1_int64
         return
      end if

      nlist = size(p_list)
      ns = len(str)

      ctr = 0_int64
      do i=1,10
         do j=1,ns
            new_str(j:j) = merge(digits(i:i),str(j:j),str(j:j)==d(1:1))
         end do
         read(new_str,*) val
         if (val < 100000_int64) continue
         if (val > nlist) continue
         if (p_list(val)) ctr = ctr + 1_int64
      end do
   end function count_primes

   !> returns the binomial coefficient
   integer(int64) function binomial(n, k) result(nk)
      integer(int64), intent(in) :: n,k
      nk = factorial(n) / (factorial(k) * factorial(n - k))
   end function binomial

   !> uses log-gamma to compute the binomial coefficient
   integer(int64) function choice(n, k) result(nk)
      integer(int64), intent(in) :: n,k
      nk = nint(exp(factl(n) - factl(k) - factl(n-k)))
   end function choice

   !> uses iterative approach to binomial function
   integer(int64) function choose(n, k) result(C)
      integer(int64), intent(in) :: n, k
      integer(int64) :: d

      if (k > n) then
         C = -1_int64
      else if (k == 1_int64) then
         C = 1_int64
      else
         C = 1
         do d=1,k
            C = (C*n)/d  ! ensure n/k isn't done first, as that can give 0
            n = n - 1
         end do !- d
      end if
   end function choose

   !> returns the factorial using the Gamma function
   real(dp) function factl(n) result(F)
      integer(int64), intent(in) :: n
      real(dp) :: x
      x = real(n,dp)
      F = exp(gammaln(x+1_dp))
   end function factl

   !> initialize the random number generator based on clock time
   subroutine init_random_seed()
      integer(int32), allocatable :: seed(:)
      integer(int32) :: i, un, istat, dt(8), pid
      integer(int32) :: t
      integer :: n

      call random_seed(size = n)
      allocate(seed(n))
      ! First try if the OS provides a random number generator
      open(newunit=un, file="/dev/urandom", access="stream", &
           form="unformatted", action="read", status="old", iostat=istat)
      if (istat == 0) then
         read(un) seed
         close(un)
      else
         ! Fallback to XOR:ing the current time and pid. The PID is
         ! useful in case one launches multiple instances of the same
         ! program in parallel.
         call system_clock(t)
         if (t == 0) then
            call date_and_time(values=dt)
            t = (dt(1) - 1970) * 365 * 24 * 60 * 60 * 1000 &
                 + dt(2) * 31 * 24 * 60 * 60 * 1000 &
                 + dt(3) * 24 * 60 * 60 * 1000 &
                 + dt(5) * 60 * 60 * 1000 &
                 + dt(6) * 60 * 1000 + dt(7) * 1000 &
                 + dt(8)
         end if
         pid = getpid()
         t = ieor(t, int(pid, kind(t)))
         do i = 1, n
            seed(i) = lcg(t)
         end do
      end if
      call random_seed(put=int(seed))
   contains
    ! This simple PRNG might not be good enough for real work, but is
    ! sufficient for seeding a better PRNG.
      integer(int32) function lcg(s)
        integer(int32) :: s
        if (s == 0) then
           s = 104729_int32
        else
           s = mod(s, 4294967296_int32)
        end if
        s = mod(s * 279470273_int32, 4294967291_int32)
        lcg = int(mod(s, int(huge(0))))
      end function lcg
   end subroutine init_random_seed

   !> swap two variables values
   pure subroutine swap(a,b)
      integer(int64), intent(inout) :: a,b
      integer(int64) :: T
      t = a
      a = b
      b = t
   end subroutine swap

   !> implements iterative greatest common denominator
   recursive function gcd(a, b) result(g)
      integer(int64), intent(in) :: a, b
      integer(int64), parameter :: zero=0, one=1, two=2
      integer(int64) :: u, v, t, k
      integer(int64) :: g

      u = abs(a)
      v = abs(b)

      if (u < v) call swap(u,v)

      if (v == zero) then
         g = u
         return
      end if

      k = one
      do while ( (mod(u,two) == zero) .and. (mod(v,two) == zero))
         u = u / two
         v = v / two
         k = k * two
      end do

      t = merge(u, -v, mod(u,two)==zero)

      do while (t /= zero)
         do while (mod(t, two) == zero)
            t = t / two
         end do

         if (t > zero) then
            u = t
         else
            v = -t
         endif
         t = u - v
      end do

      g = u*k
      return
   end function gcd

   !> extended greatest common denominator
   integer(int64) function egcd(a,b) result(g)
      integer(int64), intent(in) :: a,b
      integer(int64) :: lastx,lasty,x,y,u,v,q,t
      u = a; v = b
      lastx=1_int64; lasty=0_int64
      x=0_int64; y=1_int64
      do while (v /= 0_int64)
         q = u/v
         t = v
         v = mod(a,v)
         u = t

         t = x
         x = lastx - q*x
         lastx = t

         t = y
         y = lasty - q*u
         lasty = t
      end do
      g = lastx
   end function egcd

   !> least common multiple of two numbers
   integer(int64) function lcm(a,b)
      integer(int64), intent(in) :: a,b
      lcm = a*b/gcd(a,b)
   end function lcm

   !> returns the length of the Collatz sequence starting at n
   !> taken from https://github.com/aphirst/EulerFTN/blob/master/functions.f90
   recursive function Collatz(n, lengths, memoise) result(coll)
      integer(int64), intent(in) :: n
      integer(int64), intent(inout) :: lengths(:)
      logical, intent(in), optional :: memoise
      integer(int64) :: coll

      if (n <= size(lengths)) then
         if (lengths(n) /= 0_int64) then
            coll = lengths(n)
            return
         else if (n == 1_int64) then
            coll = 1_int64
            lengths(1) = 1_int64
            return
         end if
      end if

      if ( modulo(n,2_int64) == 0_int64 ) then
         coll = 1_int64 + Collatz(n/2_int64 , lengths, .true.)
      else
         coll = 1_int64 + Collatz(3_int64*n + 1_int64 , lengths, .true.)
      end if

      if (present(memoise)) then
         if (memoise) then
            if (n <= size(lengths)) lengths(n) = coll
         end if
      end if
  end function Collatz

    !>  Miller-Rabin primality test
   logical function mr_prime(n,kopt) result(bool)
      integer(int64), intent(in) :: n
      integer(int64), optional :: kopt
      integer(int64), parameter :: two=2_int64
      integer(int64) :: k
      integer(int64) :: s, d, i, a, x, r

      k = 30_int64
      if (present(kopt)) k = kopt

      ! test the small, known primes
      if (any(n==small_primes)) then
         bool = .true.
         return
      end if

      ! eliminate numbers less than 30 that aren't prime as above
      if (n < 30_int64) then
         bool = .false.
         return
      end if

      ! eliminate factors of the small known primes
      do i=1,size(small_primes,1)
         if (mod(n,small_primes(i))==0_int64) then
            bool = .false.
            return
         end if
      end do

      s = 1_int64
      do while ((mod(n-1_int64, two**s))==0_int64)
         s = s + 1_int64
      end do !- while

      d = (n-1_int64) / two**s

      do i=1,k
         a = randrange(two, n-two)
         x = mod(a**d, n)
         if (x < 1_int64 .or. x > (n -1_int64)) then
            do r=1,s-1
               x = mod(x**(two*r), n)
               if (x == 1_int64) then
                  bool = .false.
                  return
               end if
            end do !-r
         end if
      end do !- i

      bool = .true.
      return
   end function mr_prime

   !> Solovay–Strassen primality test
   logical function ss_prime(n, kopt) result(bool)
      integer(int64), intent(in) :: n
      integer(int64), optional :: kopt
      integer(int64) :: a, x, y, k, i

      k = 16_int64
      if (present(kopt)) k = kopt

      ! check simple cases
      if (n < 30_int64) then
         if (any(n == small_primes)) then
            bool = .true.
         else
            bool = .false.
         end if
         return
      end if

      ! check if mod of small primes
      do i=1,size(small_primes)
         if (mod(n,small_primes(i))==0_int64) then
            bool = .false.
            return
         end if
      end do !- i

      ! do main probabilistic test
      do i=1,k
         a = randrange(2_int64, n-1)
         x = legendre(a, n)
         y = powmod(a, (n-1)/2, n)
         if (x == 0_int64 .or. y /= mod(x,n)) then
            bool = .false.
            return
         end if
      end do !- i

      bool = .true.

   end function ss_prime

   !> returns a random number in the range (a,b)
   integer(int64) function randrange(a, b) result(x)
      integer(int64), intent(in) :: a, b
      real(dp) :: xx
      call random_number(xx)
      x = floor(a + xx * real(max(a,b) - min(a, b)))
   end function randrange

   !> Legendre symbol (a/p); see https://en.wikipedia.org/wiki/Legendre_symbol
   integer(int64) function legendre(a, p) result(L)
      integer(int64), intent(in) :: a, p

      if (.not.is_prime6(p)) then
         print '("error: p=",i0,", which is not prime")',p
         stop
      end if

      ! check simple case of p=2, then mod(a,p)==0
      if (p == 2_int64) then
         L = merge(1_int64, 0_int64, mod(a,2) == 0_int64)
      else if (mod(a,p) == 0_int64) then
         L = 0_int64
      else
         L = powmod(a, (p-1)/2, p)
         if (L /= 1_int64) then
            L = -1_int64
         end if
      end if
   end function legendre

   !> sum the digits (size(a)=20 is larger than what int64 holds)
   integer(int64) function digit_sum(n) result(D)
      integer(int64), intent(in) :: n
      integer(int64) :: m, a(20), b=10_int64, i

      a=0_int64
      m=n
      i=1_int64
      do while (m /= 0_int64)
         a(i) = mod(m,b)
         m = m / b
         i = i + 1_int64
      end do
      D = sum(a)
   end function digit_sum

   !> returns divisor sum square
   function sigma2(pow, n) result(divs)
      integer(int64) :: n, pow
      integer(int64), dimension(0:n) :: divs
      integer(int64) :: i, d, ip

      divs(0:1) = [0_int64,1_int64]
      do i=2,n
         divs(i) = i**pow + 1_int64
      end do !- i
      do i=2,int(n**0.5)+1_int64
         ip = i**pow
         divs(i*i) = divs(i*i) + ip
         do d=i*(i+1),n,i
            divs(d) = divs(d) + ip + (d/i)**pow
         end do !- d
      end do !- i
   end function sigma2

   !> returns true if a & b are within [1,S] and false otherwise
   logical function legal_move(a,b,S)
      integer(int64), intent(in) :: a,b,S
      legal_move = (a > 0_int64) .and. (a < S+1_int64) &
               .and. (b > 0_int64) .and. (b < S+1_int64)
   end function

   !> returns the lagged fibonacci generator (for Euler 149)
   subroutine lfg(n,S)
      integer(int64), intent(in) :: n
      integer(int64), intent(inout) :: S(n)
      integer(int64) :: k

      ! fill primer array
      do k=1,55
         S(k) = mod(100003_int64 - k*(200003_int64 - k*k*300007_int64), 1000000_int64) - 500000_int64
      end do !- k

      do k=56,n
         S(k) = mod(S(k-24) + S(k-55) + 1000000_int64, 1000000_int64) - 500000_int64
      end do !- k
   end subroutine lfg

   !> returns the nth Catalan number (recall 0-based indexing for such numbers)
   integer(int64) function catalan(n) result(C)
      integer(int64), intent(in) :: n
      integer(int64) :: k, nm, dm
      nm = 1
      dm = 1
      do k=2,n
         nm = nm * (n+k)
         dm = dm * k
      end do !- k
      C = nm/dm
   end function catalan

   !> computes the integer division & remainder of two numbers
   function divmod(a,b) result(R)
      integer(int64), intent(in) :: a,b
      integer(int64) :: R(2)
      R(1) = a/b
      R(2) = mod(a,b)
   end function divmod

   !> given the string str, returns the nth permutation of it (untested, may not compile)
   recursive subroutine perm2(n, str) result(S)
      integer(int64), intent(in) :: n
      character(len=*), intent(in) :: str
      character(len=len(str)) :: S
      integer(int64) :: q(2)
      if (len(str)==1) return
      q = divmod(n, factorial(len(str)-1_int64))
      S = str(q(1):q(1)) + perm2(q(2), str(:q) // str(q+1:))
   end subroutine perm2

   !> returns the digital root of the number (e.g., 635 -> 6+3+5=14 -> 1+4=5)
   integer(int64) function digital_root(n) result(dr)
      integer(int64), intent(in) :: n
      dr = 1_int64 + mod(n-1,9_int64)
   end function digital_root

    !> divmod subroutine to get faster division & remainder functions
   subroutine divmod(num,den,remainder,quotient)
      integer(int64), intent(in) :: num, den
      integer(int64), intent(out) :: remainder, quotient
      quotient = int(num / den, int64)
      remainder = num - quotient * den
   end subroutine divmod

   !> returns the hyperbinary representation of m
   integer(int64) function hyper_binary(m) result(b)
      integer(int64), intent(in) :: m
      integer(int64) :: a, n
      n = m
      a = 1
      b = 0
      do while (n > 0)
         if (mod(n,2) == 1) then
            b = a + b
         else
            a = a + b
         end if
         n = n/2_int64
      end do
   end function hyper_binary

   !> returns mod(a^p, m) but more efficiently (~O(log(p)))
   recursive integer(int64) function powmod(a, p, m) result(R)
      integer(int64), intent(in) :: a, p, m
      integer(int64) :: temp

      ! take care of simple cases first
      if (p == 0_int64) then
         R = 1_int64
      else if (p == 1_int64) then
         R = mod(a, m)
      else
         temp = powmod(a, p/2_int64, m)
         if (mod(p,2_int64) == 0_int64) then
            R = mod(temp*temp, m)
         else
            R = mod(a*mod(temp*temp, m), m)
         end if
      end if
   end function powmod

   !> generate boolean array of square-free numbers using a sieve
   subroutine squarefree_sieve(n, sqfp)
      integer(int64), intent(in) :: n
      logical, intent(out) :: sqfp(n)
      integer(int64), dimension(n) :: mu

      ! get the moebius mu to n
      call moebius_mu_sieve(n, mu)

      ! the square-free numbers are the non-zero entries here
      sqfp(1:n) = mu(1:n) /= 0_int64
   end subroutine squarefree_sieve

   !> generates the moebius mu function
   subroutine moebius_mu_sieve(n, mu)
      integer(int64), intent(in) :: n
      integer(int64), dimension(n), intent(out) :: mu
      logical, dimension(n) :: primes
      integer(int64) :: k, p

      ! get the primes <= to n
      call prime_sieve(n, primes)

      ! generate the mu
      mu(:) = 1_int64
      do k=2,n
         if (primes(k)) then
            mu(k:n:k) = -mu(k:n:k)
            p = k*k
            mu(p:n:p) = 0_int64
         end if
      end do !- k
   end subroutine moebius_mu_sieve

   integer(int64) function isqrt(n) result(x)
      integer(int64), intent(in) :: n
      integer(int64) :: y
      x = y
      y = (x + 1) / 2
      do while (y < x)
         x = y
         y = (x + n / x) / 2
      end do !-
   end function isqrt
end module EulerCommon


! 7.17a в учебнике

program ex_7_17a
    implicit none

    integer, allocatable    :: A(:,:), Inline(:), Indexes(:,:), k(:)
    logical, allocatable    :: mask(:)
    integer                 :: In, Out, x, y, i, max, t, j, pos

    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) x, y
        allocate(A(x,y))
        read(In, *) (A(:,i), i = 1, y)
    close (In)

    max = maxval(A)

    Inline = reshape(A, [x*y])
    mask = Inline == max

    pos = count(mask)

    k = pack([(i,i=1,x*y)], mask)
    allocate(Indexes(pos,2))

    do t = 1, pos

        i = mod(k(t),x)
        j = k(t) / x

        if (i == 0) then
            i = x
        else
            j = j + 1
        endif

        Indexes(t,:) = [i, j]
    enddo

    open (file=output_file, newunit=Out)
        write(Out, *) 'Наибольший элемент:', max
        write(Out, *) 'X, Y координаты элемента(ов)'
        write(Out, '(I2,A1,I2)') (Indexes(i,1), ',' ,Indexes(i,2), i = 1, pos)
    close (Out)

end program ex_7_17a


program test

  call check_classical

end program test

subroutine check_classical

  use linear_algebra

  implicit none

  ! Test forward and backward substitutions
  test_sub : block

    real(8), allocatable :: L(:,:), U(:,:)
    real(8), allocatable :: b(:), x1(:), x2(:)
    integer :: i, j, m, n, flag

    ! Size of the linear system
    m = 100
    n = 100

    ! Memory allocations
    allocate(L(m,n))
    allocate(U(m,n))
    allocate(b(m))
    allocate(x1(m))
    allocate(x2(m))

    ! Fill in with values
    call random_number(L)
    call random_number(U)
    call random_number(b)

    ! Zero the upper/lower triangular part
    do j = 1, m
       do i = 1, n
          if (i .gt. j) then
             U(i,j) = 0.0d0
          else if (i .eq. j) then
          else
             L(i,j) = 0.0d0
          end if
       end do
    end do

    ! Check forward sub
    call fwdsub(L, b, x1, flag)
    print *, flag, x1 - solve(L,b)

    ! Check backward sub
    call backsub(U, b, x2, flag)
    print *, flag, x2 - solve(U, b)

    ! Clean up memory
    deallocate(L, U, b, x1, x2)

  end block test_sub

  test_iter_sol: block

    real(8), allocatable :: x(:), bb(:), A(:,:)
    integer :: iter, flag
    real(8) :: tol,omega

    allocate(A(2,2), bb(2), x(2))

    A(1,1) = 12.0d0
    A(2,1) = 5.0d0

    A(1,2) = 3.0d0
    A(2,2) = 7.0d0

    bb(1) = 11.0d0
    bb(2) = 13.0d0

    x(1) = 0.0d0
    x(2) = 0.0d0

    call dseidel(A, bb, 1.0d0, 1000, 1.0d-8, x, iter, tol, flag)
    print *, x, iter, tol, flag, solve(A, bb)

    call dsor(A, bb, 1.1d0, 1000, 1.0d-8, x, iter, tol, flag)
    print *, x, iter, tol, flag, solve(A, bb)

    call djacobi(A, bb, 1000, 1.0d-8, x, iter, tol, flag)
    print *, x, iter, tol, flag, solve(A, bb)

    deallocate(A, bb, x)

  end block test_iter_sol

  print *, "problem5"
  problem5: block

    integer, parameter :: npts = 100
    real(8), parameter :: max_tol = 1.0d-6
    integer, parameter :: max_it  = 100000

    real(8) :: x(npts), xtmp(npts), b(npts), A(npts,npts)
    integer :: iter, flag, i, j
    real(8) :: tol, omega(20)
    real(8) :: scale = 1.0d0

    call assemble_system(0.0d0, 1.0d0, npts, A, b, x)
    xtmp = solve(A,b)

    print *, 'gauss seidel'
    call assemble_system(0.0d0, 1.0d0, npts, A, b, x)
    call dseidel(A, b, 1.0d0, max_it, max_tol, x, iter, tol, flag)
    print *, 'seidel', tol, iter
    open(11, file='seidel.dat')
    do i = 1, npts
       write(11, *) dble(i)/dble(npts), x(i), xtmp(i)
    end do
    close(11)

    call assemble_system(0.0d0, 1.0d0, npts, A, b, x)
    call dsor(A, b, 1.99d0, max_it, max_tol, x, iter, tol, flag)
    print *, 'sor', 1.99d0, tol, iter
!!$
!!$    print *, 'SOR'
!!$    do j = 1, 15
!!$       omega(j) = 1.84d0 + dble(j)/100.0d0
!!$       print *, omega(j)
!!$       call assemble_system(0.0d0, 1.0d0, npts, A, b, x)
!!$       call dsor(A, b, omega(j), max_it, max_tol, x, iter, tol, flag)
!!$       print *, 'sor', omega(j), tol, iter
!!$    end do

    open(11, file='sor.dat')
    do i = 1, npts
       write(11, *) dble(i)/dble(npts), x(i), xtmp(i)
    end do
    close(11)

    print *, 'gauss jacobi'
    call assemble_system(0.0d0, 1.0d0, npts, A, b, x)
    call djacobi(A, b, max_it, max_tol, x, iter, tol, flag)
    print *, 'jacobi', tol, iter
    open(11, file='jacobi.dat')
    do i = 1, npts
       write(11, *) dble(i)/dble(npts), x(i), xtmp(i)
    end do
    close(11)

  end block problem5

end subroutine check_classical

subroutine assemble_system(a, b, npts, V, rhs, x)

  use linear_algebra, only : inv

  real(8), intent(in)  :: a, b ! bound of domain
  integer              :: npts ! number of points
  real(8), intent(out) :: V(npts,npts)

  real(8), intent(out) :: rhs(npts)
  real(8), intent(out) :: x(npts)
  integer              :: m, n, i, j
  real(8) :: h
  real(8), parameter :: PI = 3.141592653589793d0

  h = (b-a)/dble(npts+1)
  V = 0.0d0

  m = npts
  n = npts
  do j = 1, m
     do i = 1, n
        if (i .eq. j-1) then
           V(i,j) = -1.0d0
        else if (i .eq. j+1) then
           V(i,j) = -1.0d0
        else if (i .eq. j) then
           V(i,i) = 2.0d0 + 4.0d0*h*h
        else
           ! skip
        end if
     end do
  end do

  ! Assemble the RHS
  rhs = 0.0d0
  rhs(1) = -1.0d0
  rhs(npts) = 2.0d0

  ! Initial solution profile
  do i = 1, npts
     x(i) = - 1.0d0 + 2.75d0*(dble(i)*h)
  end do

end subroutine assemble_system


! { dg-do run }
!
! PR fortran/50981
! The program used to dereference a NULL pointer when trying to access
! an optional dummy argument to be passed to an elemental subprocedure.
!
! Original testcase from Andriy Kostyuk <kostyuk@fias.uni-frankfurt.de>

PROGRAM test
  IMPLICIT NONE
  REAL(KIND=8), DIMENSION(2) :: aa, rr

  aa(1)=10.
  aa(2)=11.

  ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'

  rr=f1(aa,1)
  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  IF (ANY(rr /= (/ 110, 132 /))) STOP 1

  rr=0
  rr=ff(aa,1)
  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  IF (ANY(rr /= (/ 110, 132 /))) STOP 2

  ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'

  rr=0
  rr=f1(aa)
  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  IF (ANY(rr /= (/ 110, 132 /))) STOP 3

  rr = 0
  rr=ff(aa)
  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
  IF (ANY(rr /= (/ 110, 132 /))) STOP 4

CONTAINS

    ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b)
      IMPLICIT NONE
      REAL(KIND=8), INTENT(IN) :: a
      INTEGER, INTENT(IN), OPTIONAL :: b
      REAL(KIND=8), DIMENSION(2) :: ac
      ac(1)=a
      ac(2)=a**2
      ff=SUM(gg(ac,b))
    END FUNCTION ff

    ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b)
      IMPLICIT NONE
      REAL(KIND=8), INTENT(IN) :: a
      INTEGER, INTENT(IN), OPTIONAL :: b
      REAL(KIND=8), DIMENSION(2) :: ac
      ac(1)=a
      ac(2)=a**2
      f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg
    END FUNCTION f1

    ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
      IMPLICIT NONE
      REAL(KIND=8), INTENT(IN) :: a
      INTEGER, INTENT(IN), OPTIONAL :: b
      INTEGER ::b1
      IF(PRESENT(b)) THEN
        b1=b
      ELSE
        b1=1
      ENDIF
      gg=a**b1
    END FUNCTION gg

END PROGRAM test


	SUBROUTINE initialdata(Nx,Ny,x,y,u,uold)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets initial data for nonlinear Klein-Gordon equation
	! in 2 dimensions
	! u_{tt}-u_{xx}+u_{yy}+u=Es*u^3+
	!
	! The boundary conditions are u(x=-Lx*\pi,y)=u(x=Lx*\pi,y),
	!	u(x,y=-Ly*\pi)=u(x,y=Ly*\pi)
	! The initial condition is u=0.5*exp(-x^2-y^2)*sin(10*x+12*y)
	!
	! INPUT
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	! .. Vectors ..
	!  x				= x locations
	!  y				= y locations
	!
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= initial solution
	!  uold 			= approximate solution based on time derivative of
	!					initial solution
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny
	REAL(KIND=8), DIMENSION(1:NX), INTENT(IN) 			:: x
	REAL(KIND=8), DIMENSION(1:NY), INTENT(IN) 			:: y
	COMPLEX(KIND=8), DIMENSION(1:NX,1:NY), INTENT(OUT)	:: u,uold
	INTEGER(kind=4)										:: i,j
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		u(1:Nx,j)=0.5d0*exp(-1.0d0*(x(1:Nx)**2 +y(j)**2))*&
					sin(10.0d0*x(1:Nx)+12.0d0*y(j))
	END DO
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		uold(1:Nx,j)=0.5d0*exp(-1.0d0*(x(1:Nx)**2 +y(j)**2))*&
					sin(10.0d0*x(1:Nx)+12.0d0*y(j))
	END DO
	!$OMP END PARALLEL DO

	END SUBROUTINE initialdata


program test_mean
use stdlib_experimental_error, only: assert
use stdlib_experimental_kinds, only: sp, dp, int32, int64
use stdlib_experimental_io, only: loadtxt
use stdlib_experimental_stats, only: mean
implicit none

real(dp), parameter :: dptol =10 * epsilon(1._dp)

real(dp), allocatable :: d(:, :)
real(dp), allocatable :: d8(:, :, :, :, :, :, :, :)
complex(dp), allocatable :: cd8(:, :, :, :, :, :, :, :)

!dp
call loadtxt("array3.dat", d)

call assert( mean(d) - sum(d)/real(size(d), dp) < dptol)
call assert( sum( abs( mean(d,1) - sum(d,1)/real(size(d,1), dp) )) < dptol)
call assert( sum( abs( mean(d,2) - sum(d,2)/real(size(d,2), dp) )) < dptol)

!dp rank 8
allocate(d8(size(d,1), size(d,2), 3, 4, 5, 6, 7, 8))
d8(:, :, 1, 4, 5 ,6 ,7 ,8)=d;
d8(:, :, 2, 4, 5 ,6 ,7 ,8)=d * 1.5_dp;
d8(:, :, 3, 4, 5 ,6 ,7 ,8)=d * 4._dp;

call assert( mean(d8) - sum(d8)/real(size(d8), dp) < dptol)

call assert( sum( abs( mean(d8,1) - sum(d8,1)/real(size(d8,1), dp) )) < dptol)
call assert( sum( abs( mean(d8,2) - sum(d8,2)/real(size(d8,2), dp) )) < dptol)
call assert( sum( abs( mean(d8,3) - sum(d8,3)/real(size(d8,3), dp) )) < dptol)
call assert( sum( abs( mean(d8,4) - sum(d8,4)/real(size(d8,4), dp) )) < dptol)
call assert( sum( abs( mean(d8,5) - sum(d8,5)/real(size(d8,5), dp) )) < dptol)
call assert( sum( abs( mean(d8,6) - sum(d8,6)/real(size(d8,6), dp) )) < dptol)
call assert( sum( abs( mean(d8,7) - sum(d8,7)/real(size(d8,7), dp) )) < dptol)
call assert( sum( abs( mean(d8,8) - sum(d8,8)/real(size(d8,8), dp) )) < dptol)

!cdp rank 8
allocate(cd8(size(d,1), size(d,2), 3, 4, 5, 6, 7, 8))
cd8 = cmplx(1._dp, 1._dp, kind=dp)*d8

call assert( abs(mean(cd8) - sum(cd8)/real(size(cd8), dp)) < dptol)

call assert( sum( abs( mean(cd8,1) - sum(cd8,1)/real(size(cd8,1), dp) )) < dptol)
call assert( sum( abs( mean(cd8,2) - sum(cd8,2)/real(size(cd8,2), dp) )) < dptol)
call assert( sum( abs( mean(cd8,3) - sum(cd8,3)/real(size(cd8,3), dp) )) < dptol)
call assert( sum( abs( mean(cd8,4) - sum(cd8,4)/real(size(cd8,4), dp) )) < dptol)
call assert( sum( abs( mean(cd8,5) - sum(cd8,5)/real(size(cd8,5), dp) )) < dptol)
call assert( sum( abs( mean(cd8,6) - sum(cd8,6)/real(size(cd8,6), dp) )) < dptol)
call assert( sum( abs( mean(cd8,7) - sum(cd8,7)/real(size(cd8,7), dp) )) < dptol)
call assert( sum( abs( mean(cd8,8) - sum(cd8,8)/real(size(cd8,8), dp) )) < dptol)
contains

end program


! OPERATIONS        Operations on itself
! trans_V9          Transpose of a 2nd order tensor with 9 components
! dev_V9            Deviatoric part of a 2nd order tensor with 9 components
! tr_V9             Trace of a 9 component voigt vector
! det_V9            Determinant of 2nd order 9-component tensor
! inv_V9            Inverse of 2nd order 9-component tensor
!
! Operations on full matrices
! det_M             Determinant of 1x1, 2x2 or 3x3 matrix
! inv_M3            Subroutine to calculate inverse of 3x3 matrix
! inv_M             Subroutine to calculate inverse of general matrix
! trans_M           Transpose of square matrix
! tr_M              Trace of a general square matrix
! norm_V3           Norm of a 1st order tensor with 3 components
! norm_V9           Norm of a general vector

Module Operations
use Conversions
use Contractions
Implicit none
	CONTAINS
!==============================================================================
FUNCTION trans_V9(b) RESULT (a)
Implicit none

    DOUBLE PRECISION, INTENT (IN) :: b(9)
    DOUBLE PRECISION :: a(9)

    a(1:3)=b(1:3)
    a((/4,5,6,7,8,9/))=b((/8,9,7,6,4,5/))

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION dev_V9(A) RESULT (Ad)
Implicit none

    DOUBLE PRECISION, INTENT(IN)  :: A(1:9)
    DOUBLE PRECISION              :: Ad(1:9),Avol

    Avol = SUM(A(1:3))
    Ad=A; Ad(1:3)=A(1:3)-Avol/3.d0

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION tr_V9(a) RESULT(tra)
Implicit none

      DOUBLE PRECISION, INTENT (IN) :: a(9)
      DOUBLE PRECISION :: tra
      tra=sum(a(1:3));

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION det_V9(A) RESULT(detA)
Implicit none

    DOUBLE PRECISION, INTENT (IN) :: A(9)
    DOUBLE PRECISION :: detA
    detA=-A(7)*A(2)*A(6)+A(4)*A(5)*A(6)+  &
          A(7)*A(8)*A(9)-A(1)*A(5)*A(9)-  &
          A(4)*A(8)*A(3)+A(1)*A(2)*A(3)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION inv_V9(A) RESULT (inv_A)
Implicit none

    DOUBLE PRECISION      ::    A(9), inv_A(9),det_A

    det_A =  -A(7)*A(2)*A(6)+A(4)*A(5)*A(6)+&
              A(7)*A(8)*A(9)-A(1)*A(5)*A(9)-&
              A(4)*A(8)*A(3)+A(1)*A(2)*A(3)

    IF ( ABS(det_A) .LT. 1.0e-25) THEN
       write(*,*) ''
       write(*,*) 'WARNING! Matrix close to being singular. (inv_V9b)'
       write(*,*) ''
       det_A=1.d-15
    ENDIF

    inv_A(1)=(-A(5)*A(9)+A(2)*A(3))/det_A
    inv_A(4)=( A(7)*A(9)-A(4)*A(3))/det_A
    inv_A(7)=( A(5)*A(4)-A(2)*A(7))/det_A

    inv_A(8)=( A(5)*A(6)-A(8)*A(3))/det_A
    inv_A(2)=(-A(7)*A(6)+A(1)*A(3))/det_A
    inv_A(5)=(-A(5)*A(1)+A(8)*A(7))/det_A

    inv_A(6)=(-A(2)*A(6)+A(8)*A(9))/det_A
    inv_A(9)=( A(4)*A(6)-A(1)*A(9))/det_A
    inv_A(3)=( A(2)*A(1)-A(8)*A(4))/det_A

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION invar_V9(a) RESULT(i)
Implicit none

      DOUBLE PRECISION, INTENT (IN) :: a(9)
      DOUBLE PRECISION :: i(3),aa(9)
      aa=V9_d_V9(a,a)
      i(1) = sum(a(1:3))
      i(2) = sum(a*a)
      i(3) = sum(aa*a);

END FUNCTION
!==============================================================================

! OPERATIONS ON MATRICES

!==============================================================================
FUNCTION det_M(A) RESULT (DET_A)
Implicit none

    INTEGER              :: N
    DOUBLE PRECISION     :: A(:,:), DET_A

    DET_A=0.d0
    N = size(A,1)

    SELECT CASE (N)
        CASE(1)
           DET_A=A(1,1)
        CASE(2)
           DET_A=A(1,1)*A(2,2)-A(1,2)*A(2,1)
        CASE(3)
           DET_A=A(1,1)*A(2,2)*A(3,3)+A(1,2)*A(2,3)*A(3,1)+&
           A(1,3)*A(2,1)*A(3,2)-A(1,1)*A(2,3)*A(3,2)-&
           A(1,2)*A(2,1)*A(3,3)-A(1,3)*A(2,2)*A(3,1)
    END SELECT

END FUNCTION
!==============================================================================

!==============================================================================
recursive SUBROUTINE inv_M3(A,inv_A)
Implicit none

    DOUBLE PRECISION A(3,3), inv_A(3,3), det_A

    det_A =  -A(1,3)*A(2,2)*A(3,1)+A(1,2)*A(2,3)*A(3,1)+&
              A(1,3)*A(2,1)*A(3,2)-A(1,1)*A(2,3)*A(3,2)-&
              A(1,2)*A(2,1)*A(3,3)+A(1,1)*A(2,2)*A(3,3)

    IF ( ABS(det_A) .LT. 1.0e-25) THEN
       write(*,*) ''
       write(*,*) 'WARNING! Matrix close to being singular. (inv_M3)'
       write(*,*) ''
       det_A=1.d-15
    ENDIF

    inv_A(1,1)=(-A(2,3)*A(3,2)+A(2,2)*A(3,3))/det_A
    inv_A(1,2)=( A(1,3)*A(3,2)-A(1,2)*A(3,3))/det_A
    inv_A(1,3)=( A(2,3)*A(1,2)-A(2,2)*A(1,3))/det_A

    inv_A(2,1)=( A(2,3)*A(3,1)-A(2,1)*A(3,3))/det_A
    inv_A(2,2)=(-A(1,3)*A(3,1)+A(1,1)*A(3,3))/det_A
    inv_A(2,3)=(-A(2,3)*A(1,1)+A(2,1)*A(1,3))/det_A

    inv_A(3,1)=(-A(2,2)*A(3,1)+A(2,1)*A(3,2))/det_A
    inv_A(3,2)=( A(1,2)*A(3,1)-A(1,1)*A(3,2))/det_A
    inv_A(3,3)=( A(2,2)*A(1,1)-A(2,1)*A(1,2))/det_A

END SUBROUTINE
!==============================================================================

!==============================================================================
recursive SUBROUTINE inv_M(A,inv_A)
!   Purpose: Inverts a matrix (taken from Fortran 90 Cooper Redwine).
Implicit none

    INTEGER ::  n
    DOUBLE PRECISION, INTENT(in)  :: A(:,:)
    DOUBLE PRECISION, INTENT(out) :: inv_A(:,:)
    DOUBLE PRECISION, ALLOCATABLE :: temp(:)
    DOUBLE PRECISION, ALLOCATABLE :: C(:,:)
    INTEGER ::  i, j, m

    n = size(A,1)
	m = size(A,2)

    IF (n/=m) THEN
      write(*,*) 'ERROR! Matrix is not square. (inv_M)'
    END IF

    ALLOCATE(C(n,2*n), temp(2*n))
	C(:,1:n) = A
	C(:,n+1:2*n) = 0.0
    DO i=1,n
      C(i,n+i) = 1.0
    END DO

    ! Gauss-Jordan elimination

    DO j=1,n !Loop over first n columns of matrix

      ! Find row index m of element with largest magnitude
      m = j  ! Start on the diagonal
      DO i=j+1,n
        IF (ABS(C(i,j)) > ABS(C(m,j))) m = i
      END DO

      ! Exchange row m with row j
      temp = C(j,:); C(j,:) = C(m,:); C(m,:) = temp

      C(j,:) = C(j,:)/C(j,j)  ! Divide row j by a(j,j)

      DO i=1,n  ! Loop over each row of matrix
         ! Subtract a(i,j) times row j from row i
         IF (i/=j) C(i,:) = C(i,:)-C(i,j)*C(j,:)
      END DO

    END DO

    inv_A = C(:,n+1:2*n)

END SUBROUTINE
!==============================================================================

!==============================================================================
FUNCTION trans_M(a) RESULT(at)
Implicit none

    DOUBLE PRECISION, INTENT (IN) :: a(:,:)
    DOUBLE PRECISION              :: at(size(a,2),size(a,1))
    INTEGER                       :: I,J

    DO I=1,size(a,2)
       DO J=1,size(a,1)
          at(I,J)=a(J,I)
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION tr_M(a) RESULT (tra)
Implicit none

      INTEGER i
      DOUBLE PRECISION, DIMENSION(:,:), INTENT (IN) :: a
      DOUBLE PRECISION :: tra
      if(size(a,2).ne.size(a,1))then
        write(*,*) 'not square matrix in us_trM_f';read(*,*)
      else
        tra=0.d0;DO i=1,size(a,1);tra=tra+a(i,i);ENDDO
      endif

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION norm_V3(A) RESULT (nA)
Implicit none

    DOUBLE PRECISION, INTENT(IN) ::A(3)
    DOUBLE PRECISION :: nA

    nA=sqrt((A(1)**2+A(2)**2+A(3)**2))

END FUNCTION
!==============================================================================

FUNCTION norm_V9(A) RESULT (nA)
Implicit none

    DOUBLE PRECISION, INTENT(IN) ::A(1:9)
    DOUBLE PRECISION :: nA

    nA=dsqrt( dabs(sum(A*A)) )

END FUNCTION
!==============================================================================

END MODULE


subroutine chol(a, deter)
  implicit none

  real(8), dimension(:,:), intent(inout) :: a
  real(8), intent(out) :: deter

  integer :: n, i, j, k

  n = size(a(1,:))

  if(a(1,1) .le. 1.e-8) then
    print*, "A matriz pode non ser definida positiva"
    stop
  end if

  deter = a(1,1)
  a(1,1) = sqrt(a(1,1))

  do i=2,n
      a(i,1)=a(i,1)/a(1,1)
  end do

  do k =2,n
     do j=1,k-1
       a(k,k)=a(k,k)-a(k,j)*a(k,j)
     end do

     if(a(k,k) .le. 1.e-8) then
       print*, "A matriz pode ser non definida"
       stop
     end if
    deter=deter*a(k,k)
    a(k,k) = sqrt(a(k,k))

    do i=k+1,n
      do j=1,k-1
        a(i,k) = a(i,k) - a(i,j)*a(k,j)
      end do
      a(i,k) = a(i,k)/a(k,k)
    end do
    !deter = deter*a(k,k)
  end do

  print*, 'Fact Cholesky: '
  do i=1,n
    print*, a(i,:)
  end do
  print*,

end subroutine


PROGRAM main
!
! Purpose:
!  Just for homework 11 in chapter6
!
! Record of revisions:
!    Date   Programmer  Description of change
!    ====   ==========  =====================
!  04/12/17  hopeful       Original code
!
IMPLICIT NONE

REAL, EXTERNAL :: r
INTEGER :: theta
REAL :: e

e = 0
DO WHILE (e < 0.6)
    DO theta = 0, 360, 5
        WRITE (*,*) 'The r = ', r(theta,e), ' km when e = ', e, ' and theta = ', theta, '.'
    END DO
e = e + 0.25
END DO

END PROGRAM main

! 人造卫星相对地球中心的距离
REAL FUNCTION r(theta, e)
IMPLICIT NONE

REAL, PARAMETER :: p = 1200
REAL, PARAMETER :: DEG2RAD = 3.141592653589 / 180.0
INTEGER :: theta
REAL :: e

r = p / (1 + e * COS(theta * DEG2RAD))
RETURN
END FUNCTION r


program P14715
    implicit none
    integer :: energy, factor_count
    integer :: i

    read (*, *) energy
    factor_count = 0
    do i = 2, energy - 1
        do while (mod(energy, i) == 0)
            energy = energy / i
            factor_count = factor_count + 1
        end do
    end do

    if (factor_count == 0) then
        write (*, '(I0)') 0
    else
        write (*, '(I0)') ceiling(log(real(factor_count)) / log(2.0))
    end if
end program P14715