module quadglobal
use mpmodule
implicit none
integer ndebug, nerror, nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2, &
  nwords1, nwords2
end module

subroutine f_main

!   David H. Bailey   8 April 2017

!   This is the ARPREC Fortran-90 version for a single processor.

!   This software is provided for research purposes only.
!   Commercial usage requires license agreement.

!   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 2D quadrature routine 'quadts2d', which employs
!   the error function.  The function quadts2d is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   2D finite open interval.  It can also be used for certain integrals on
!   infinite intervals, by making a suitable change of variable -- see below.

!   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.

!   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 mpmodule
use mpmodulex
use quadglobal
implicit none
integer i, kdebug, lev, ndp1, ndp2, neps1, neps2, nq1, nq2, n, n1
parameter (kdebug = 2, ndp1 = 120, ndp2 = 240, neps1 = -ndp1, neps2 = -ndp2, &
  nq1 = 9, nq2 = 8 * 2 ** nq1)
double precision dplog10q, d1, d2, second, tm0, tm1, tm9
type (mp_real) c2, c3, cat, catalan, err, quadts2d, fun1, fun2, &
  fun3, fun4, fun5, fun6, fun7, fun8, t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2)
type (mp_realx) fun11, fun12, fun21, fun22, fun31, fun32, fun41, fun42, &
  fun51, fun52, fun61, fun62, fun71, fun72, fun81, fun82, y1, y2
external quadts2d, catalan, fun1, fun11, fun12, fun2, fun21, fun22, &
  fun3, fun31, fun32, fun4, fun41, fun42, fun5, fun51, fun52, fun6, &
  fun61, fun62, fun7, fun71, fun72, fun8, fun81, fun82, second
save

call mpinit (ndp1)
call mpinitx (ndp2)
call mpsetprec (ndp1)
call mpgetprecwords (nwords1)
call mpsetprec (ndp2)
call mpgetprecwords (nwords2)
call mpsetprecwords (nwords1)
ndigits1 = ndp1
ndigits2 = ndp2
nepsilon1 = neps1
nepsilon2 = neps2
mpoud = ndp1
ndebug = kdebug
nerror = 0
nquadl = nq1
write (6, 1) nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2
1 format ('Quadts2d test:  Quadlevel =',i6/'Digits1 =',i6,'  Digits2 =',i6, &
  '  Epsilon1 =',i6,' Epsilon2 =',i6)

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

tm0 = second ()
call initqts (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)
cat = catalan ()
tm9 = tm1 - tm0
c2 = 2.d0
c3 = 3.d0

!   Begin quadrature tests.

write (6, 11)
11 format (/ &
  'Problem 1: Int_0^1 Int_0^1 sqrt(s^2+t^2) ds dt')
lev = 9
write (6, 3) lev
3 format ('Level =',i4)
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadts2d (fun1, fun11, fun12, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 4) tm1 - tm0
4 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call mpwrite (6, t1)
t2 = sqrt (c2) / 3.d0 - log (c2) / 6.d0 + log (c2 + sqrt (c2)) / 3.d0
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
5 format ('Actual error =',f10.6,'x10^',i5)
tm9 = tm9 + (tm1 - tm0)

write (6, 12)
12 format (/&
  'Problem 2: Int_0^1 Int_0^1 sqrt(1+(s-t)^2) ds dt')
lev = 6
write (6, 3) lev
call mpsetprecwords (nwords2)
y1 = 0.d0
y2 = 1.d0
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quadts2d (fun2, fun21, fun22, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
t2 = -sqrt (c2) / 3.d0 - log (sqrt (c2) - 1.d0) / 2.d0 &
     + log (sqrt (c2) + 1.d0) / 2.d0 + c2 / 3.d0
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 13)
13 format (/ &
  'Problem 3: Int_-1^1 Int_-1^1 1/sqrt(1+s^2+t^2) ds dt')
lev = 7
write (6, 3) lev
y1 = -1.d0
y2 = 1.d0
tm0 = second ()
t1 = quadts2d (fun3, fun31, fun32, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
t2 = 4.d0 * log (2.d0 + sqrt (c3)) - 2.d0 * mppic / 3.d0
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 14)
14 format (/&
  'Problem 4: Int_0^pi Int_0^pi log (2-cos(s)-cos(t)) ds dt')
lev = 9
write (6, 3) lev
call mpsetprecwords (nwords2)
y1 = 0.d0
y2 = mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quadts2d (fun4, fun41, fun42, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
t2 = 4.d0 * mppic * cat - mppic**2 * log (c2)
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 15)
15 format (/&
  'Problem 5: Int_0^inf Int_0^inf sqrt(s^2+s*t+t^2) * exp(-s-t) ds dt')
lev = 9
write (6, 3) lev
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadts2d (fun5, fun51, fun52, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
t2 = 1.d0 + 0.75d0 * log (c3)
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 16)
16 format (/&
  'Problem 6: Int_0^1 Int_0^1 1/(sqrt((1-s)*(1-t))*(s+t)) ds dt')
lev = 9
write (6, 3) lev
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadts2d (fun6, fun61, fun62, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
t2 = 4.d0 * cat
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 17)
17 format (/ &
'Problem 7: Int_0^1 Int_0^t 1/sqrt(1+s^2+t^2) ds dt')
lev = 6
write (6, 3) lev
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadts2d (fun7, fun71, fun72, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
t2 = -mppic / 12.d0 - log (c2) / 2.d0 + log (1.d0 + sqrt (c3))
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 18)
18 format (/ &
  'Problem 8: Int_0^pi Int_0^y cos(s)*sin(t)/exp[s+t] ds dt')
lev = 6
write (6, 3) lev
call mpsetprecwords (nwords2)
y1 = 0.d0
y2 = mppicx
call mpsetprecwords (nwords1)
tm0 = second ()
t1 = quadts2d (fun8, fun81, fun82, y1, y2, lev, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 4) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.25d0 * (1.d0 + exp (-mppic))
call decmdq (t2 - t1, d1, n1)
write (6, 5) d1, n1
tm9 = tm9 + (tm1 - tm0)

write (6, 6) tm9
6 format ('Total CPU time =',f12.6)
stop
end

function fun1 (s, t)

!   fun1 (s,t) = sqrt[s^2+t^2]

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun1, s1, t1
type (mp_realx) s, t

s1 = s
t1 = t
fun1 = sqrt (s**2 + t**2)
return
end

function fun11 (s)
use mpmodulex
implicit none
type (mp_realx) fun11, s
fun11 = 0.d0
return
end

function fun12 (s)
use mpmodulex
implicit none
type (mp_realx) fun12, s
fun12 = 1.d0
return
end

function fun2 (s, t)

!   fun2 (s,t) = Sqrt[1 + (s - t)^2]

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun2, s1, t1
type (mp_realx) s, t

s1 = s
t1 = t
fun2 = sqrt (1.d0 + (s1 - t1)**2)
return
end

function fun21 (s)
use mpmodulex
implicit none
type (mp_realx) fun21, s
fun21 = 0.d0
return
end

function fun22 (s)
use mpmodulex
implicit none
type (mp_realx) fun22, s
fun22 = 1.d0
return
end

function fun3 (s, t)

!   fun3 (s,t) = 1/sqrt[1+s^2+t^2]

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun3, s1, t1
type (mp_realx) s, t

s1 = s
t1 = t
fun3 = 1.d0 / sqrt (1.d0 + s**2 + t**2)
return
end

function fun31 (s)
use mpmodulex
implicit none
type (mp_realx) fun31, s
fun31 = -1.d0
return
end

function fun32 (s)
use mpmodulex
implicit none
type (mp_realx) fun32, s
fun32 = 1.d0
return
end

function fun4 (s, t)

!   fun4 (s,t) = log (2 - cos(s) - cos(t))
!               = log (2*sin(s/2)^2 + 2*sin(t/2)^2)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun4, s1, t1
type (mp_realx) s, t

s1 = s
t1 = t
! fun4 = log (2.d0 - cos (s1) - cos (t1))
fun4 = log (2.d0 * sin (0.5d0 * s1) ** 2 + 2.d0 * sin (0.5d0 * t1) ** 2)
return
end

function fun41 (s)
use mpmodulex
implicit none
type (mp_realx) fun41, s
fun41 = 0.d0
return
end

function fun42 (s)
use mpmodulex
implicit none
type (mp_realx) fun42, s
fun42 = mppic
return
end

function fun5 (s, t)

!   fun5 (s,t) = sqrt ((1/s-1)^2 + (1/s-1)*(1/t-1) + (1/t-1)^2)
!                / (s^2 * t^2 * exp(1/s + 1/t - 2))

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun5, s1, t1, s2, t2, sq
type (mp_realx) s, t

s1 = s
t1 = t
if (s1 > 0.d0 .and. t1 > 0.d0) then
  s2 = 1.d0 / s1 - 1.d0
  t2 = 1.d0 / t1 - 1.d0
  if (s2 + t2 < 4.d0 * ndigits1) then
    sq = sqrt (s2**2 + s2 * t2 + t2**2)
    fun5 = sq / (s1**2 * t1**2) * exp (-s2 - t2)
  else
    fun5 = 0.d0
  endif
else
  fun5 = 0.d0
endif

return
end

function fun51 (s)
use mpmodulex
implicit none
type (mp_realx) fun51, s
fun51 = 0.d0
return
end

function fun52 (s)
use mpmodulex
implicit none
type (mp_realx) fun52, s
fun52 = 1.d0
return
end

function fun6 (s, t)

!   fun6 (s,t) = 1/(sqrt((1-s)*(1-t)) * (s+t))

use mpmodule
use mpmodulex
use quadglobal
implicit none
type (mp_real) fun6, s1, t1, s2, t2
type (mp_realx) s, t

s1 = s
t1 = t
call mpsetprecwords (nwords2)
s2 = 1.d0 - s
t2 = 1.d0 - t
call mpsetprecwords (nwords1)
if (s2 > 0.d0 .and. t2 > 0.d0) then
  fun6 = 1.d0 / (sqrt (s2 * t2) * (s1 + t1))
else
  fun6 = 0.d0
endif
return
end

function fun61 (s)
use mpmodulex
implicit none
type (mp_realx) fun61, s
fun61 = 0.d0
return
end

function fun62 (s)
use mpmodulex
implicit none
type (mp_realx) fun62, s
fun62 = 1.d0
return
end

function fun7 (s, t)

!   fun7 (s,t) = 1/sqrt[1+s^2+t^2]

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun7, s1, t1
type (mp_realx) s, t

s1 = s
t1 = t
fun7 = 1.d0 / sqrt (1.d0 + s1**2 + t1**2)
return
end

function fun71 (s)
use mpmodulex
implicit none
type (mp_realx) fun71, s
fun71 = 0.d0
return
end

function fun72 (s)
use mpmodulex
implicit none
type (mp_realx) fun72, s
fun72 = s
return
end

function fun8 (s, t)

!   fun8 (s,t) = cos(s) * cos(t) / exp (s+t)

use mpmodule
use mpmodulex
implicit none
type (mp_real) fun8, s1, t1, s2, t2
type (mp_realx) s, t

s1 = s
t1 = t
fun8 = cos(s1) * sin(t1) / exp(s1+t1)
return
end

function fun81 (s)
use mpmodulex
implicit none
type (mp_realx) fun81, s
fun81 = 0.d0
return
end

function fun82 (s)
use mpmodulex
implicit none
type (mp_realx) fun82, s
fun82 = s
return
end

subroutine initqts (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
!   12 * 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-09-10

use mpmodule
use quadglobal
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2, ntab, ntabx
real*8 h
parameter (iprint = 1000)
type (mp_real) eps2, p2, spi, t1, t2, t3, t4, t5, u1, u2, &
  wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqts: Error function quadrature initialization')
endif

eps2 = mpreal (10.d0) ** nepsilon2
p2 = 0.5d0 * mppic
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) < eps2) goto 100
enddo

write (6, 2) nq2
2 format ('initqts: 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 ('initqts: Table spaced used =',i8)
endif
goto 130

120 continue

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

130  continue

return
end

function quadts2d (fun, fun1, fun2, y1, y2, lev, nq1, nq2, wk, xk)

!   This routine computes the 2-d integral of the function fun:
!       y2   fun2[x]
!     Int  Int  fun[x,y] dx dy
!       y1   fun1[x]
!   with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   wk and xk are precomputed tables of abscissas and weights.  The function
!   fun is not evaluated at endpoints.  The array x_k contains 1 minus
!   the abscissas; the wk array contains the weights at these abscissas.

!   David H. Bailey     2004-09-10

use mpmodule
use mpmodulex
use quadglobal
implicit none
integer i, ierror, ip(0:100), izx, iz1, iz2, iz3, iz4, j, k, k1, k2, k3, &
  lev, n, nds, nq1, nq2, nqq1
parameter (izx = 2)
logical logx1, logx2, logy1, logy2
real*8 d1, d2, d3, d4, dwmx, dwi1, dwi2, dwi3, dwi4, dwimx, dwj1(0:nq2), &
  dwj2(0:nq2), dwj3(0:nq2), dwj4(0:nq2), dwjmx, dplog10q, eps1, eps2, err, h
type (mp_real) quadts2d, fun, tsum1, tsum2, tsum3, &
  s1, s2, s3, t1, t2, t3, t4, tw1, tw2, tw3, tw4, wij, wk(-1:nq2), xk(-1:nq2)
type (mp_realx) ax, bx, ay, by, f1, f2, fun1, fun2, xki, xx1, xx2, y1, y2, &
  ykj, yy1, yy2
integer jz1(0:nq2), jz2(0:nq2), jz3(0:nq2), jz4(0:nq2)
external fun, fun1, fun2, dplog10q

call mpsetprecwords (nwords2)
ay = 0.5d0 * (y2 - y1)
by = 0.5d0 * (y2 + y1)
call mpsetprecwords (nwords1)

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadts2d: 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

k = lev
h = 0.5d0 ** k
k1 = ip(nqq1-k)
k2 = ip(nqq1-k+1)
k3 = ip(nqq1-k+2)
dwmx = -99999.d0
dwimx = -99999.d0
dwjmx = -99999.d9
dwi1 = -99999.d0
dwi2 = -99999.d0
dwi3 = -99999.d0
dwi4 = -99999.d0
tsum1 = 0.d0
tsum2 = 0.d0
tsum3 = 0.d0

do i = 0, n, k1
  dwj1(i) = -99999.d0
  dwj2(i) = -99999.d0
  dwj3(i) = -99999.d0
  dwj4(i) = -99999.d0
  jz1(i) = 0
  jz2(i) = 0
  jz3(i) = 0
  jz4(i) = 0
enddo

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

do j = 0, n, k1

  if (mod (j, 100) == 0) write (6, *) j

  call mpsetprecwords (nwords2)
  ykj = 1.d0 - xk(j)
  yy1 = - ay * ykj + by
  yy2 = ay * ykj + by
!    logy1 = yy1 > y1
!    logy2 = yy2 < y2
  logy1 = .true.
  logy2 = .true.
  f1 = fun1 (yy1)
  f2 = fun2 (yy1)
  ax = 0.5d0 * (f2 - f1)
  bx = 0.5d0 * (f2 + f1)
  call mpsetprecwords (nwords1)
  iz1 = 0
  iz2 = 0
  iz3 = 0
  iz4 = 0

  do i = 0, n, k1
    call mpsetprecwords (nwords2)
    xki = 1.d0 - xk(i)
    xx1 = - ax * xki + bx
    xx2 = ax * xki + bx
!        logx1 = xx1 > f1
!        logx2 = xx2 < f2
    logx1 = .true.
    logx2 = .true.
    call mpsetprecwords (nwords1)
    wij = wk(i) * wk(j)

    if (logx1 .and. logy1 .and. iz1 < izx .and. jz1(i) < izx) then
      t1 = fun (xx1, yy1)
      tw1 = t1 * wij
      dwi1 = dplog10q (tw1)
      dwj1(i) = dwi1
      if (dwi1 < nepsilon1) then
        iz1 = iz1 + 1
        jz1(i) = jz1(i) + 1
      else
        iz1 = 0
        jz1(i) = 0
      endif
    else
      t1 = 0.d0
      tw1 = 0.d0
    endif

    if (i > 0 .and. logx2 .and. logy1 .and. iz2 < izx .and. jz2(i) < izx) &
      then
      t2 = fun (xx2, yy1)
      tw2 = t2 * wij
      dwi2 = dplog10q (tw2)
      dwj2(i) = dwi2
      if (dwi2 < nepsilon1) then
        iz2 = iz2 + 1
        jz1(i) = jz1(i) + 1
      else
        iz2 = 0
        jz2(i) = 0
      endif
    else
      t2 = 0.d0
      tw2 = 0.d0
    endif

    t1 = ax * ay * (tw1 + tw2)
    tsum1 = tsum1 + t1
    if (mod (i, k2) == 0 .and. mod (j,k2) == 0) tsum2 = tsum2 + t1
    if (mod (i, k3) == 0 .and. mod (j,k3) == 0) tsum3 = tsum3 + t1
    dwmx = max (dwmx, dplog10q (tw1), dplog10q (tw2))
  enddo

  call mpsetprecwords (nwords2)
  f1 = fun1 (yy2)
  f2 = fun2 (yy2)
  ax = 0.5d0 * (f2 - f1)
  bx = 0.5d0 * (f2 + f1)
  call mpsetprecwords (nwords1)

  do i = 0, n, k1
    call mpsetprecwords(nwords2)
    xki = 1.d0 - xk(i)
    xx1 = - ax * xki + bx
    xx2 = ax * xki + bx
!        logx1 = xx1 > f1
!        logx2 = xx2 < f2
    logx1 = .true.
    logx2 = .true.
    call mpsetprecwords (nwords1)
    wij = wk(i) * wk(j)

    if (j > 0 .and. logx1 .and. logy2 .and. iz3 < izx .and. jz3(i) < izx) &
      then
      t3 = fun (xx1, yy2)
      tw3 = t3 * wij
      dwi3 = dplog10q (tw3)
      dwj3(i) = dwi3
      if (dwi3 < nepsilon1) then
        iz3 = iz3 + 1
        jz3(i) = jz3(i) + 1
      else
        iz3 = 0
        jz3(i) = 0
      endif
    else
      t3 = 0.d0
      tw3 = 0.d0
    endif

    if (i > 0 .and. j > 0 .and. logx2 .and. logy2 .and. iz4 < izx &
      .and. jz4(i) < izx) then
      t4 = fun (xx2, yy2)
      tw4 = t4 * wij
      dwi4 = dplog10q (tw4)
      dwj4(i) = dwi4
      if (dwi4 < nepsilon1) then
        iz4 = iz4 + 1
        jz4(i) = jz4(i) + 1
      else
        iz4 = 0
        jz4(i) = 0
      endif
    else
      t4 = 0.d0
      tw4 = 0.d0
    endif

    t1 = ax * ay * (tw3 + tw4)
    tsum1 = tsum1 + t1
    if (mod (i, k2) == 0 .and. mod (j,k2) == 0) tsum2 = tsum2 + t1
    if (mod (i, k3) == 0 .and. mod (j,k3) == 0) tsum3 = tsum3 + t1
    dwmx = max (dwmx, dplog10q (tw3), dplog10q (tw4))
  enddo

  dwimx = max (dwimx, dwi1, dwi2, dwi3, dwi4)
enddo

do i = 0, n, k1
  dwjmx = max (dwjmx, dwj1(i), dwj2(i), dwj3(i), dwj4(i))
enddo

!   Compute s1 = current integral approximation and err = error estimate.

s1 = h**2 * tsum1
s2 = 4.d0 * h**2 * tsum2
s3 = 16.d0 * h**2 * tsum3
eps1 = dwmx + nepsilon1
eps2 = max (dwimx, dwjmx)
d1 = dplog10q (abs (s1 - s2))
d2 = dplog10q (abs (s1 - s3))
d3 = eps1 - 1.d0
d4 = eps2 - 1.d0

if (k <= 2) then
  err = 0.d0
  elseif (d1 .eq. -99999.d0) then
  err = -99999.d0
else
  err = 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) nint (err)
2 format ('quadts2d: est error = 10^',i5,'; approx value =')
  call mpwrite (6, s1)
endif
if (k >= 3 .and. err < eps1) goto 140
if (k >= 3 .and. err < eps2) goto 120

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

120 continue

write (6, 4) nint (err), ndigits1
4 format ('quadts2d: 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 ('quadts2d: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quadts2d = s1
return
end

function catalan ()
use mpmodule
use quadglobal
implicit none
integer k
real*8 dk, eps
type (mp_real) catalan, c1, c2, c4, c8, r16, t1, t2, t3
type (mp_real) x1, x2, x3, x4, x5, x6

c1 = 1.d0
c2 = 2.d0
c4 = 4.d0
c8 = 8.d0
r16 = 1.d0 / 16.d0
t1 = 0.d0
t2 = 1.d0
eps = mpreal (10.d0) ** nepsilon1

do k = 0, 10000000
  dk = k
  t3 = t2 * (c8 / (8.d0 * dk + 1.d0) ** 2 + c8 / (8.d0 * dk + 2.d0) ** 2 &
       + c4 / (8.d0 * dk + 3.d0) ** 2 - c2 / (8.d0 * dk + 5.d0) ** 2 &
       - c2 / (8.d0 * dk + 6.d0) ** 2 - c1 / (8.d0 * dk + 7.d0) ** 2)
  t1 = t1 + t3
  t2 = r16 * t2
  if (t3 < 1.d-5 * eps) goto 100
enddo

write (6, *) 'catalan: error - contact author'

100 continue

catalan = 1.d0 / 8.d0 * mppic * log (c2) + 1.d0 / 16.d0 * t1
return
end

function dplog10q (a)

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

use mpmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (mp_real) a

! call mpmdc (a%mpr, da, ia)
da = a
ia = 0
if (da .eq. 0.d0) then
  dplog10q = -99999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
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 mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

! call mpmdc (a%mpr, da, ia)
da = a
ia = 0
if (da .ne. 0.d0) then
  t1 = xlt * ia + 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


program intrinsics_29
implicit none

real(4) :: random_sp
real(8) :: random_dp

call random_number(random_sp)
call random_number(random_dp)
print*, random_sp, random_dp

end program intrinsics_29


! Make sure the f2c calling conventions work
! { dg-do run }
! { dg-options "-ff2c" }

function f(x)
  f = x
end function f

complex function c(a,b)
  c = cmplx (a,b)
end function c

double complex function d(e,f)
  double precision e, f
  d = cmplx (e, f, kind(d))
end function d

subroutine test_with_interface()
  interface
     real function f(x)
       real::x
     end function f
  end interface

  interface
     complex function c(a,b)
       real::a,b
     end function c
  end interface

  interface
     double complex function d(e,f)
       double precision::e,f
     end function d
  end interface

  double precision z, w

  x = 8.625
  if (x /= f(x)) call abort ()
  y = f(x)
  if (x /= y) call abort ()

  a = 1.
  b = -1.
  if (c(a,b) /= cmplx(a,b)) call abort ()

  z = 1.
  w = -1.
  if (d(z,w) /= cmplx(z,w, kind(z))) call abort ()
end subroutine test_with_interface

external f, c, d
real f
complex c
double complex d
double precision z, w

x = 8.625
if (x /= f(x)) call abort ()
y = f(x)
if (x /= y) call abort ()

a = 1.
b = -1.
if (c(a,b) /= cmplx(a,b)) call abort ()

z = 1.
w = -1.
if (d(z,w) /= cmplx(z,w, kind(z))) call abort ()

call test_with_interface ()
end


program P18187
    implicit none
    integer :: count, lines
    integer, dimension(102) :: sequence
    integer :: i

    read (*, *) lines
    do i = 1, ((lines + 2) / 3)
        sequence(i * 3 - 2) = i * 2 - 1
        sequence(i * 3 - 1) = i * 2
        sequence(i * 3) = i * 2 + 1
    end do

    count = 1
    do i = 1, lines
        count = count + sequence(i)
    end do
    write (*, '(I0)') count

end program P18187


*
*     -----------------------------------------------------------------
*           G R A C A H
*     -----------------------------------------------------------------
*
*
      SUBROUTINE GRACAH(I,J,K,L,M,N,RAC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
*
*      SUBROUTINE TO CALCULATE RACAH COEFFICIENTS.
*      THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE.
*      WRITTEN BY N. S. SCOTT
*      Modified by C. Froese Fischer, March 11, 1988 to use
*         table look-up
*
      LOGICAL SAVE
      COMMON/FACT/GAM(100)
      DIMENSION RACA(0:4,0:4,0:4,0:4,0:4,0:4)
      DATA RACA/15625*1.D-20/
      DATA ZERO,ONE,TWO,UNDEF/0.D0,1.D0,2.D0,1.D-20/
*
      SAVE = .FALSE.
      IMAX = MAX(I,J,K,L,M,N)
      IF (IMAX .LE. 4) THEN
         RAC = RACA(I,J,K,L,M,N)
         IF (RAC .EQ. UNDEF) THEN
            SAVE = .TRUE.
         ELSE
            RETURN
         END IF
      END IF
      J1 = I+J+M
      J2 = K+L+M
      J3 = I+K+N
      J4 = J+L+N
      IF (MOD(J1,2) .EQ. 0  .AND.  MOD(J2,2) .EQ. 0   .AND.
     :    MOD(J3,2) .EQ. 0  .AND.  MOD(J4,2) .EQ. 0 )  THEN
          J1 = J1/2
          J2 = J2/2
          J3 = J3/2
          J4 = J4/2
          IF (MAX(I,J,M) .LE. J1 .AND.  MAX(K,L,M) .LE. J2  .AND.
     :        MAX(I,K,N) .LE. J3 .AND.  MAX(J,L,N) .LE. J4  )  THEN
              J5 = (I+J+K+L)/2
              J6 = (I+L+M+N)/2
              J7 = (J+K+M+N)/2
              NUMIN = MAX(J1, J2, J3, J4) + 1
              NUMAX = MIN(J5, J6, J7)     + 1
              RAC = ONE
              ICOUNT = 0
              DO 10 KK = NUMIN+1,NUMAX
                KI = NUMAX - ICOUNT
                RAC = ONE - (RAC*(KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)))/
     :                   ((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4))
                ICOUNT = ICOUNT+1
  10          CONTINUE
              RAC = RAC*EXP(
     :              (GAM(NUMIN+1) - GAM(NUMIN-J1) - GAM(NUMIN-J2) -
     :               GAM(NUMIN-J3) - GAM(NUMIN-J4) - GAM(J5+2-NUMIN)-
     :               GAM(J6+2-NUMIN)-GAM(J7+2-NUMIN)) +
     :              (GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(J1+2) +
     :               GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2) +
     :               GAM(J3+1-I)+GAM(J3+1-K)+GAM(J3+1-N)-GAM(J3+2) +
     :               GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))/TWO)
              IF (MOD(J5+NUMIN,2) .EQ. 0) RAC = -RAC
          ELSE
              RAC = ZERO
          END IF
      ELSE
         RAC = ZERO
      END IF
      IF (SAVE) RACA(I,J,K,L,M,N) = RAC
      RETURN
      END


program xruin
! 11/17/2021 09:03 PM loop over spending rate
! 11/17/2021 05:00 PM loop over leverage
! 11/17/2021 10:41 AM simulate the probability of ruin given spending rate and return distribution
use kind_mod    , only: dp
use ziggurat_mod, only: rnor, jsrset
use stats_mod   , only: mean, median, mode
implicit none
integer, parameter :: nsteps = 40, nsim = 10000, nnfut = 4, h = nsteps/nnfut, nspend = 3, nlev = 3
real(kind=dp)      :: avg_return, sd_return, spend, wealth, wealth_init, wealth_final(nsim), &
                      spent(nsim), portfolio_return, leverage
integer            :: i, ifut, ilev, isim, ispend, tsurv(nsim), nfut(nnfut)
real(kind=dp), parameter :: xsim = real(nsim,kind=dp), leverage_min = 0.0_dp, leverage_h = 0.5_dp, &
                      spend_min = 0.02_dp, spend_h = 0.01_dp
character (len=20) :: label_fut(nnfut)
avg_return  = 0.06_dp ! average annual stock market return
sd_return   = 0.15_dp ! standard deviation of stock market returns
wealth_init = 1.00_dp
write (*,"(*(a10))") "#sim","avg_ret","sd_ret"
write (*,"(i10,2f10.2)") nsim,avg_return,sd_return
nfut = [(ifut*h,ifut=1,nnfut)] ! time horizons for which survival probabilities shown
do ifut=1,nnfut
   write (label_fut(ifut),"('p',i0)") nfut(ifut) ! labels for survival probabilities
end do
write (*,"(/,a6,10x,2a7,2a13)") "spend","spent","spent","years_surv","years_surv"
write (*,"(a6,a10,2a7,4a13,*(a7))") "rate","leverage","median","mean","median", &
       "mean","wealth_avg","wealth_surv",(trim(label_fut(ifut)),ifut=1,nnfut)
do ispend=1,nspend
   do ilev=1,nlev
      spend = spend_min + (ispend-1)*spend_h ! spending rate
      call jsrset(123456)    ! reset the seed to get the same normal variates for each level of spending and leverage
      leverage = leverage_min + (ilev-1)*leverage_h ! allocation to stock market
      spent = 0.0_dp
      do isim=1,nsim
         wealth = wealth_init
         do i=1,nsteps ! loop over time periods
            portfolio_return = leverage * (avg_return + sd_return*rnor())
            wealth = (wealth - spend) * (1 + portfolio_return) ! withdraw "spend" at beginning of period, invest the remainder
            spent(isim) = spent(isim) + spend ! cumulative amount spent
            if (wealth < spend) exit ! ran out of money
         end do
         wealth_final(isim) = wealth
         tsurv(isim) = i ! time that wealth survived
      end do
      write (*,"(f6.3,f10.4,2f7.3,4(1x,f12.4),*(1x,f6.4))") spend,leverage,median(spent),mean(spent), &
        median(tsurv),sum(tsurv)/xsim,mean(wealth_final),mean(pack(wealth_final,tsurv > nsteps)), &
        [(count(tsurv > nfut(ifut)),ifut=1,nnfut)]/xsim
   end do
   write (*,*)
end do
end program xruin


PROGRAM ApplicationDriverGeometry

  USE KindModule, ONLY: &
    DP, Zero, One, Pi
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_E0, iX_B1, iX_E1, &
    iE_B0, iE_E0, iE_B1, iE_E1, &
    iZ_B0, iZ_E0, iZ_B1, iZ_E1, nDOFX, nNodesX
  USE GeometryFieldsModule, ONLY: &
    uGF, iGF_Gm_dd_11, iGF_Gm_dd_22, iGF_Gm_dd_33
  USE WeakDerivatives, ONLY: &
    ComputeWeakDerivatives_X0, &
    ComputeWeakDerivatives_X1, &
    ComputeWeakDerivatives_X2, &
    ComputeWeakDerivatives_X3, &
    ComputeChristoffel
  USE InputOutputModuleHDF, ONLY: &
    WriteDataset1DHDF, &
    WriteDataset3DHDF, &
    CreateGroupHDF
  USE InputOutputUtilitiesModule, ONLY: &
    NodeCoordinates, Field3D
  USE ReferenceElementModuleX, ONLY: &
    NodeNumberTableX
  USE ReferenceElementModule, ONLY: &
    NodeNumberTable
  USE MeshModule, ONLY: &
    MeshX, CreateMesh
  USE HDF5

  IMPLICIT NONE

  CHARACTER(32) :: ProgramName
  CHARACTER(32) :: CoordinateSystem
  INTEGER       :: nSpecies, iDim
  INTEGER       :: nNodes, iX1, iX2, iX3, iNodeX, iZ2, iZ3, iZ4
  INTEGER       :: nE, bcE, nX(3), bcX(3), swX(3)
  REAL(DP)      :: xL(3), xR(3), ZoomX(3) = One
  REAL(DP)      :: eL, eR, ZoomE = One
  REAL(DP)      :: t_end

  REAL(DP), ALLOCATABLE :: &
      dG_dd_dX0(:,:,:,:,:,:), &
      dG_dd_dX1(:,:,:,:,:,:), &
      dG_dd_dX2(:,:,:,:,:,:), &
      dG_dd_dX3(:,:,:,:,:,:),  &
      Gamma_udd(:,:,:,:,:,:,:)

  ProgramName = "thornado"
  CoordinateSystem = 'SPHERICAL'
      nSpecies = 1
      nNodes   = 3

      nX  = [ 100, 100, 1 ]
      xL  = [ 0.0_DP, 0.0_DP, 0.0_DP ]
      xR  = [ 1.0_DP, Pi, 1.0_DP ]
      bcX = [ 0, 0, 0 ]
      swX = [ 1, 1, 0]

      nE    = 1
      eL    = 0.0_DP
      eR    = 1.0_DP
      bcE   = 0
      ZoomE = 1.0_DP

  CALL InitializeDriver

    CALL ComputeWeakDerivatives_X0 &
           ( iZ_B0, iZ_E0, iZ_B1, iZ_E1, uGF, dG_dd_dX0 )
    CALL ComputeWeakDerivatives_X1 &
           ( iZ_B0, iZ_E0, iZ_B1, iZ_E1, uGF, dG_dd_dX1 )

    CALL ComputeWeakDerivatives_X2 &
           ( iZ_B0, iZ_E0, iZ_B1, iZ_E1, uGF, dG_dd_dX2 )

    CALL ComputeWeakDerivatives_X3 &
           ( iZ_B0, iZ_E0, iZ_B1, iZ_E1, uGF, dG_dd_dX3 )

    CALL ComputeChristoffel( iZ_B0, iZ_E0, iZ_B1, iZ_E1, uGF, &
                             dG_dd_dX0, dG_dd_dX1, dG_dd_dX2, dG_dd_dX3, Gamma_udd )

    CALL WriteChristoffelHDF( Gamma_udd )

CONTAINS

  SUBROUTINE InitializeDriver

    USE ProgramInitializationModule, ONLY: &
      InitializeProgram
    USE ReferenceElementModule, ONLY: &
      InitializeReferenceElement
    USE ReferenceElementModuleX, ONLY: &
      InitializeReferenceElementX
    USE ReferenceElementModuleX_Lagrange, ONLY: &
      InitializeReferenceElementX_Lagrange
    USE GeometryComputationModule, ONLY: &
      ComputeGeometryX
    USE ReferenceElementModuleE, ONLY: &
      InitializeReferenceElementE
    USE ReferenceElementModuleE_Lagrange, ONLY: &
      InitializeReferenceElementE_Lagrange
    USE ReferenceElementModuleZ, ONLY: &
      InitializeReferenceElementZ
    USE ReferenceElementModule, ONLY: &
      InitializeReferenceElement
    USE ReferenceElementModule_Lagrange, ONLY: &
      InitializeReferenceElement_Lagrange

    CALL InitializeProgram &
           ( nX_Option &
               = nX, &
             swX_Option &
               = [ 1, 1, 1 ], &
             bcX_Option &
               = bcX, &
             xL_Option &
               = xL, &
             xR_Option &
               = xR, &
             nE_Option &
               = nE, &
             swE_Option &
               = 1, &
             bcE_Option &
               = bcE, &
             eL_Option &
               = eL, &
             eR_Option &
               = eR, &
             nNodes_Option &
               = nNodes, &
             CoordinateSystem_Option &
               = TRIM( CoordinateSystem ), &
             BasicInitialization_Option &
               = .TRUE. )
    ! --- Position Space Reference Element and Geometry ---

    CALL InitializeReferenceElement
    CALL InitializeReferenceElementX
    CALL InitializeReferenceElementX_Lagrange

    CALL ComputeGeometryX &
           ( iX_B0, iX_E0, iX_B1, iX_E1, uGF )

    ALLOCATE( dG_dd_dX0(1:nDOFX,0:3,0:3, iX_B0(1):iX_E0(1), &
              iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3)  ) )
    ALLOCATE( dG_dd_dX1(1:nDOFX,0:3,0:3, iX_B0(1):iX_E0(1), &
              iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3)  ) )
    ALLOCATE( dG_dd_dX2(1:nDOFX,0:3,0:3, iX_B0(1):iX_E0(1), &
              iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3)  ) )
    ALLOCATE( dG_dd_dX3(1:nDOFX,0:3,0:3, iX_B0(1):iX_E0(1), &
              iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3)  ) )
    ALLOCATE( Gamma_udd(1:nDOFX,0:3,0:3,0:3, iX_B0(1):iX_E0(1), &
              iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3)  ) )

  END SUBROUTINE InitializeDriver

  SUBROUTINE WriteChristoffelHDF( Gamma_udd )

    REAL(DP), INTENT(in) :: &
      Gamma_udd &
         (1:nDOFX,0:3,0:3,0:3, &
          iZ_B0(2):iZ_E0(2),iZ_B0(3):iZ_E0(3),iZ_B0(4):iZ_E0(4))

    CHARACTER(6)   :: FileNumberString
    CHARACTER(256) :: FileName
    CHARACTER(256) :: GroupName
    CHARACTER(256) :: DatasetName
    INTEGER        :: mu, nu, ru
    INTEGER(HID_T) :: FILE_ID
    REAL(DP)       :: Dummy3D(2,2,2) = 0.0_DP
    CHARACTER(9),  PARAMETER :: &
      OutputDirectory = '../Output'
    CHARACTER(14), PARAMETER :: &
      GeometrySuffix  = 'Christoffel'
    CHARACTER(3) :: ChristoffelNum
    CHARACTER(1) :: muc, nuc, ruc
    INTEGER :: FileNumber = 0
    INTEGER :: HDFERR

    WRITE( FileNumberString, FMT='(i6.6)') FileNumber

    FileName &
      = OutputDirectory // '/' // &
        TRIM( ProgramName ) // '_' // &
        TRIM(GeometrySuffix) // '_' // &
        FileNumberString // '.h5'

    CALL H5OPEN_F( HDFERR )

    CALL H5FCREATE_F( TRIM( FileName ), H5F_ACC_TRUNC_F, FILE_ID, HDFERR )

    GroupName = 'Spatial Grid'

    CALL CreateGroupHDF( FileName, TRIM( GroupName ) , FILE_ID )

    DatasetName = TRIM( GroupName ) // '/X1'

    CALL WriteDataset1DHDF &
           ( NodeCoordinates(MeshX(1),nX(1),nNodesX(1)),DatasetName,FILE_ID )

    DatasetName = TRIM( GroupName ) // '/X2'

    CALL WriteDataset1DHDF &
           ( NodeCoordinates(MeshX(2),nX(2),nNodesX(2)),DatasetName, FILE_ID )

    DatasetName = TRIM( GroupName ) // '/X3'

    CALL WriteDataset1DHDF &
           ( NodeCoordinates(MeshX(3),nX(3),nNodesX(3)),DatasetName, FILE_ID )

    GroupName = 'Geometry Fields'

    CALL CreateGroupHDF( FileName, TRIM( GroupName ), FILE_ID )

    DO mu = 0, 3
    DO nu = 0, 3
    DO ru = 0, 3

     IF (mu == 0) THEN
      muc= "0"
     ELSE IF(mu==1) THEN
      muc = "1"
     ELSE IF(mu==2) THEN
      muc = "2"
     ELSE IF(mu==3) THEN
      muc = "3"
    END IF
     IF (nu == 0) THEN
      nuc= "0"
     ELSE IF(nu==1) THEN
      nuc = "1"
     ELSE IF(nu==2) THEN
      nuc = "2"
     ELSE IF(nu==3) THEN
      nuc = "3"
    END IF
     IF (ru == 0) THEN
      ruc= "0"
     ELSE IF(ru==1) THEN
      ruc = "1"
     ELSE IF(ru==2) THEN
      ruc = "2"
     ELSE IF(ru==3) THEN
      ruc = "3"
    END IF
      ChristoffelNum = muc//nuc//ruc
      DatasetName = TRIM( GroupName ) // '/' // TRIM( ChristoffelNum )
      CALL WriteDataset3DHDF &
             ( Field3D &
                 ( Gamma_udd(1:nDOFX,mu,nu,ru,1:nX(1),1:nX(2),1:nX(3)), nX, nNodesX, &
                   nDOFX, NodeNumberTableX ), &
               DatasetName, FILE_ID )

    END DO
    END DO
    END DO

  END SUBROUTINE WriteChristoffelHDF

END PROGRAM ApplicationDriverGeometry


subroutine totass(daynr,dayl,amax,eff,lai,kdif,scv,avrad,sinld,cosld,dtga,Acanopy,Qleaf,incpar,phot_layer,frac_li)
! ----------------------------------------------------------------------
! --- calculates daily total gross assimilation (dtga) by performing
! --- a gaussian integration over time at three different times of
! --- the day, irradiance is computed and used to calculate the instan-
! --- taneous canopy assimilation, whereafter integration takes place.
! --- more information on this subroutine is given by Goudriaan, J. in:
! --- "Light Distribution. In Canopy Photosynthesis: From Basics to Applications", 2016.
! ----------------------------------------------------------------------
      Implicit None
 !     include 'constants.fi' ! (SAMUCA's Crop Modelling Shell)

      integer ghour
      integer glai
      integer gl
      integer daynr

      real dlaic
      real frac_li
      real par_check
      real par_ratio
      real lai_sl_upper(5)
      real lai_sl_bottom(5)
      real lai_sl(5)
      real lai
      real kdif
      real amax
      real avrad
      real cosld
      real dayl
      real dtga
      real dvisabs
      real eff
      real fgros
      real hour
      real pardif
      real pardir
      real phot
      real phott
      real photth
      real photl
      real phos
      real phoshd
      real phosun
      real sinb
      real sinld
      real Acanopy(3+1,5+1)
      real Qleaf(3+1,5+1)
      real incpar(3,4)
      real laic
      real kbl
      real kdrt
      real fgl
      real fgrsh
      real fgrsun
      real fslla
      real refh
      real refs
      real scv
      real visabs
      real visabst
      real visabsth
      real visll
      real visl
      real visd
      real visdf
      real vispp
      real visshd
      real vissun
      real vist
      real phot_layer(3) !Total photosynthesis per canopy layer

      !--- Gaussian arrangement for three points
      real :: gausr     = 0.3872983d0
      real :: gaussx(3) = (/0.1127017,       0.5, 0.8872983/)
      real :: gaussw(3) = (/0.2777778, 0.4444444, 0.2777778/)

      !--- Gaussian arrangement for five points
      real :: gaussx_5(5) = (/0.0469101, 0.2307534,       0.5, 0.7692465, 0.9530899/)
      real :: gaussw_5(5) = (/0.1184635, 0.2393144, 0.2844444, 0.2393144, 0.1184635/)

      !--- Daily Expected PAR Ratio [PAR/SRAD]
      real :: expected_par_ratio = 0.5d0

      !--- Initialization
      dtga          = 0.d0
      photth        = 0.d0
      incpar        = 0.d0
      Acanopy       = 0.d0
      Qleaf         = 0.d0
      par_check     = 0.d0
      visabsth      = 0.d0

      Acanopy(1, 1) = amax

      !--- three point gaussian integration over day
      if (amax .lt. 1.d-10) return

      do ghour = 1, 3

          !--- Hour at Gaussian step
          hour = 12.d0 + dayl * 0.5 * (0.5d0 + (ghour - 2) * gausr)

          !--- Compute diffuse and direct irradiance at the specified hour
          call radiat (daynr,hour,dayl,sinld,cosld,avrad,sinb,pardir,pardif)

          !--- Store incoming direct, difuse and total par radiation [W m-2]
          incpar(ghour,1) = hour
          incpar(ghour,2) = pardir
          incpar(ghour,3) = pardif
          incpar(ghour,4) = pardif + pardir

          !--- Extinction coefficients kdif,kdirbl,kdirt following Goudriaan (2016)
          refh  = (1.d0 - sqrt(1.d0 - scv))/(1.d0 + sqrt(1.d0 - scv))
          refs  = refh * 2.d0 / (1.d0 + 2.d0 * sinb)
          kbl   = 0.5d0 / sinb         ! Spherical model
          kdrt  = kbl * sqrt(1.0d0-scv)

          !--- Five point gaussian integration over lai at the given hour
          phot      = 0.d0
          visabs    = 0.d0
          do glai = 1, 5

              !--- LAI at canopy layer
              laic = lai * gaussx_5(glai)

              !--- Upper and lower lai layer aproximation
              if(glai .eq. 1)then
                  lai_sl_upper(glai)  = 0.d0
                  lai_sl_bottom(glai) = ((lai * gaussx_5(glai + 1)) + laic) / 2.d0
                  dlaic   = laic
              elseif(glai .eq. 5)then
                  lai_sl_upper(glai)  = ((lai * gaussx_5(glai - 1)) + laic) / 2.d0
                  lai_sl_bottom(glai) = lai
                  dlaic   = laic - (lai * gaussx_5(glai - 1))
              else
                  lai_sl_upper(glai)  = ((lai * gaussx_5(glai-1)) + laic) / 2.d0
                  lai_sl_bottom(glai) = ((lai * gaussx_5(glai+1)) + laic) / 2.d0
                  dlaic   = laic - (lai * gaussx_5(glai-1))
              endif

              !--- Canopy Layer LAI
              lai_sl(glai) = lai_sl_bottom(glai) - lai_sl_upper(glai)

              !--- Absorbed diffuse radiation (vidf), light from direct origine (vist) and direct light(visd)
              visdf   = (1.0d0-refh) * pardif * kdif  * exp(-kdif   * laic)
              vist    = (1.0d0-refs) * pardir * kdrt  * exp(-kdrt   * laic)
              visd    = pardir * kbl * exp(-kbl * laic)

              !--- Absorbed flux for shaded leaves [W/m2]
              visshd = visdf + vist - visd

              !--- Instantaneous Assimilation Rate of shaded leaves [kg/ha/h]
              phoshd = amax * (1.d0 - exp(-visshd * eff / amax))

              !--- Direct light absorbed by leaves perpendicular on direct beam and assimilation of sunlit leaf area
              !--- three point gaussian integration over lai layer (Added, following Goudriaan (2016))
              vispp   = pardir * (1. - scv) / sinb
              phosun  = 0.d0
              visll   = 0.d0
              do gl = 1, 5
                  vissun  = visshd + vispp * gaussx_5(gl)               ! [W/m2]
                  phos    = amax * (1.d0 - exp(-vissun * eff / amax))   ! [kg/ha/h/dgauss]
                  phosun  = phosun + phos   * gaussw_5(gl)              ! [kg/ha/h]
                  visll   = visll  + vissun * gaussw_5(gl)              ! [W/m2]
              enddo

              !--- fraction of sunlit leaf area (fslla)
              fslla   = exp(-kbl * laic)

              !--- Instantaneous assimilation rate of layer [kg/ha/h]
              photl   = fslla *   phosun  +     (1.d0 - fslla) * phoshd

              !--- Light intercepted by layer [W/m2]
              visl    = fslla *   visll   +     (1.d0 - fslla) * visshd  !Added, following Goudriaan (2016)

              !--- Absorbed light (direct + difuse) at lai depth (glai) and time (ghour) [PPFD - micromol m-2 s-1]
              Qleaf(1,glai+1)         = laic
              Qleaf(ghour+1, 1)       = hour
              Qleaf(ghour+1, glai+1)  = visl * 4.6

              !--- Assimilation Rate at lai depth (glai) and time (ghour)  [micromol(CO2) m-2 s-1]
              Acanopy(1,glai+1)       = laic
              Acanopy(ghour+1, 1)     = hour
              Acanopy(ghour+1,glai+1) = photl * (1.e3/1.e4) / 3600.d0 / 44.d0 * 1.e6

              !--- integration over lai
              phot    = phot   + gaussw_5(glai) * photl
              visabs  = visabs + gaussw_5(glai) * visl

          enddo

          phott     = phot * lai
          visabst   = visabs * lai

          !--- integration over time (hour)
          photth    = photth   + gaussw(ghour) * phott
          visabsth  = visabsth + gaussw(ghour) * visabst
          par_check = par_check + gaussw(ghour) * (pardif + pardir)
      enddo

      !--- Photosynthesis per canopy layer
      phot_layer = 0.d0
      do glai = 1,3
          do ghour = 1, 3
              phot_layer(glai) = phot_layer(glai) + ((Acanopy(ghour+1,glai+1) / (1000./10000.) * (3600.) * 44. / 1000000. ) * gaussw(ghour) * gaussw(glai))!
          enddo
      enddo

      phot_layer = phot_layer * lai * dayl !integrated in g CO2 d-1 layer-1

      !--- Check incomming PAR integration method
      par_check = par_check * dayl * 3600.d0
      dvisabs   = visabsth  * dayl * 3600.d0
      par_ratio = par_check / avrad             ! This should be around 0.5

      !--- Fraction of light absorbed by the canopy
      frac_li   = dvisabs / par_check

      !--- Total Daily Gross Photosynthesis [g]
      dtga      = photth    * dayl

      return
    end subroutine totass


	PROGRAM EDECAY
C
C	ELECTROSTATIC DECAY OF LANGMUIR WAVE
C
	REAL K0,K1,K2,K1P,K1M,K2P,K2M
	DATA TWOPI /6.28318531/
C
	FP = 22500.
	EB = 5.			! KEV
	VB = SQRT(2.*EB/.511E3)*3.E8			! M/SEC
	TE = 10.					! EV
	TI = 10.					! EV
	VS = SQRT((TE + 3.*TI)/.511E6/1836.)*3.E8       ! M/SEC
	VT2 = TE*(3.E8)**2/.511E6
C
	K0 = TWOPI*FP/VB
	W02 = (TWOPI*FP)**2 + 3.*VT2*K0**2
	W0 = SQRT(W02)
	print*,'k0,w0',k0,w0
C
C	QUADRATIC FOR K1 = DAUGHTER LANGMUIR WAVE
C	ONE OF THE SOLUTIONS WILL BE K1 = K0 AND K2 = 0.  THE OTHER
C		ONE IS THE DESIRED (NONTRIVIAL) SOLUTION
C
	AA = 3.*VT2 - VS**2
	BB = -2.*VS*(W0 - K0*VS)
	CC = (TWOPI*FP)**2 - (W0-K0*VS)**2
	DISC = BB**2 - 4.*AA*CC
	K1P = .5*(-BB+SQRT(DISC))/AA
	K1M = .5*(-BB-SQRT(DISC))/AA
C
	PRINT*,AA,BB,CC,DISC
	PRINT*,'k1+, k1-',K1P,K1M
	K2M = K0 - K1M
	K2P = K0 - K1P
	PRINT*,'k2+, k2-',K2P,K2M
	STOP
	END


    MODULE cdf_nc_f_mod
! ----------------------------------------------------------------------

!                               cdf_nc_f_mod
!                               *=*=*=*=*=*=

!  -  SUBROUTINE CDF_F(WHICH, CUM, CCUM, F, DFN, DFD, PNONC, STATUS,
!                      CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_F(F,  DFN, DFD, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_F(F, DFN, DFD, PNONC, STATUS,  CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_F(CUM, CCUM, DFN, DFD, PNONC, STATUS,
!                                  CHECK_INPUT)

!                             The Distribution
!                             ================

!    The noncentral F is the distribution of the ratio of two independent
!    random variables. The numerator random variable is distributed as a
!    noncentral chi-squared with DFN degrees of freedom and noncentrality
!    parameter PNONC divided by DFN. The denominator random variable is
!    distributed as a (central) chi-squared with DFD degrees of freedom
!    divided by DFD.

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    five arguments is to be calculated.
!  Input Range: [ 1:2 ]
!     1.  CUM and CCUM
!     2.  F
!  NOTE: DFN and DFD will not be computed because CUM is not monotone in
!    either argument.
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the noncentral f
!    distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the noncentral
!    f distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: F. The upper limit of integration of the noncentral
!    f density. The lower limit is 0.
!  Range: [ 0:10^100 ]
!  - REAL (dpkind) :: DFN. The numerator degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - REAL (dpkind) :: DFD. The denominator degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - REAL (dpkind) :: PNONC. The noncentrality parameter.
!  Range: [ 0:10^4 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 F outside range
!     -5 DFN outside range
!     -6 DFD outside range
!      3 CUM + CCUM is not nearly one
!     10 can not solve cdf_f in local_cum_nc_f
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!  NOTE: CUM and CCUM must add to (nearly) one.
!----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_mathlib_mod
      USE cdf_aux_mod
      USE zero_finder
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_nc_f, cdf_nc_f, cum_nc_f, inv_nc_f
! ..
    CONTAINS

!*********************************************************************

      FUNCTION ccum_nc_f(f,dfn,dfd,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_nc_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_f(which=1,ccum=ccum_nc_f,f=f,dfn=dfn,dfd=dfd, &
          pnonc=pnonc,status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_nc_f

!*********************************************************************

      SUBROUTINE cdf_nc_f(which,cum,ccum,f,dfn,dfd,pnonc,status, &
          check_input)
! .. Use Statements ..
        USE cdf_gamma_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: dfd, dfn, f, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: local_status, zf_status
        LOGICAL :: has_status, local_check_input
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_non_central_f%name,'cum', &
          'ccum',local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = f
        params(4) = dfn
        params(5) = dfd
        params(6) = pnonc

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_non_central_f,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

        END IF

!++++++++++++++++++++++++++++++++++++++++++++++++++
! Compute the Answers
!++++++++++++++++++++++++++++++++++++++++++++++++++

        local_status = 0

        SELECT CASE (which)

        CASE (1)
! Calculate cum and ccum

          CALL local_cum_nc_f(f,dfn,dfd,pnonc,local_cum,local_ccum, &
            status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
! Calculate f

! Start value for f
          f = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_f,3,local)

          DO
            CALL rc_interval_zf(zf_status,f,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_f(f,dfn,dfd,pnonc,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            fx = try_cum - local_cum
          END DO

! Can NOT solve for Degrees of Freedom (which=4 and 5)

        CASE (3)
! Solve for PNONC

! Start value for pnonc:
          pnonc = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_f,6,local)

          DO
            CALL rc_interval_zf(zf_status,pnonc,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_f(f,dfn,dfd,pnonc,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            fx = try_cum - local_cum
          END DO

        END SELECT

        IF (has_status) THEN
! Set the status of the zero finder
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_nc_f

!*********************************************************************

      FUNCTION cum_nc_f(f,dfn,dfd,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_nc_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_f(which=1,cum=cum_nc_f,f=f,dfn=dfn,dfd=dfd, &
          pnonc=pnonc,status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_nc_f

!*********************************************************************

      FUNCTION inv_nc_f(cum,ccum,dfn,dfd,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_nc_f
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL, INTENT (IN) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: dfd, dfn, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_f(which=2,cum=cum,ccum=ccum,f=inv_nc_f,dfn=dfn, &
          dfd=dfd,pnonc=pnonc,status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_nc_f

!*********************************************************************

      SUBROUTINE local_cum_nc_f(f,dfn,dfd,pnonc,cum,ccum,status)
!**********************************************************************
!               F -NON- -C-ENTRAL F DISTRIBUTION

!                              Function

!     Computes Non-Central F Distribution with DFN and DFD
!     Degrees of Freedom and Non-Centrality parameter PNONC

!                              Arguments

!     F --> upper limit of integration of Non-Central F
!     DFN --> degrees of freedom of numerator
!     DFD --> degrees of freedom of denominator
!     PNONC --> non-centrality parameter.
!     CUM <-- cumulative Non-Central F distribution
!     CCUM <-- compliment of cummulative (1-CUM)

!                              Method

!     Uses formula 26.6.20 of reference for infinite series.
!     Series is calculated backward and forward from j = lambda/2
!     (this is the term with the largest Poisson weight) until
!     the convergence criterion is met.
!     for speed, the incomplete beta functions are evaluated
!     by formula 26.5.16.

!               Reference

!     Handbood of Mathematical Functions
!     by Milton Abramowitz and Irene A. Stegun
!     NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55
!     March 1965
!     P 947, equations 26.6.17, 26.6.18

!                              Note

!     The sum continues until a succeeding term is less than EPS
!     times the sum (or the sum is less than 1.0e-20).  EPS is
!     set to 1.0E-4 in a data statement which can be changed.
!**********************************************************************
! .. Use Statements ..
        USE cdf_f_mod
        USE cdf_beta_mod
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: eps = 1.0E-4_dpkind
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: dfd, dfn, f, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        REAL (dpkind) :: adn, aup, b, betdn, betup, centwt, dnterm, dsum, &
          prod, sum, upterm, xmult, xnonc, xx, yy
        INTEGER :: f_status, i, icent
! ..
! .. Intrinsic Functions ..
        INTRINSIC EXP, LOG, PRESENT, REAL
! ..
        IF (f<=zero) THEN
          cum = zero
          ccum = one

          RETURN
        END IF

        IF (pnonc<1.0E-10_dpkind) THEN

!     Handle case in which the non-centrality parameter is
!     (essentially) zero.

          CALL cdf_f(which=1,cum=cum,ccum=ccum,f=f,dfn=dfn,dfd=dfd, &
            status=f_status)

          IF (f_status/=0) THEN
! cdf_f has NO answer.

            IF (PRESENT(status)) THEN
              status = 10
            ELSE
              WRITE (*,*) 'Error in local_cum_nc_f call to cdf_f'
              WRITE (*,*) 'Status: ', f_status

              STOP 'Error in local_cum_nc_f call to cdf_f'
            END IF
          END IF

          RETURN
        END IF

        xnonc = half*pnonc

! Calculate the central term of the poisson weighting factor.

        icent = xnonc
        IF (icent==0) icent = 1

! Compute central weight term

        centwt = EXP((-xnonc)+icent*LOG(xnonc)-alngam(REAL(icent+1, &
          kind=dpkind)))

!     Compute central incomplete beta term
!     Assure that minimum of arg to beta and 1 - arg is computed accurately.

        prod = dfn*f
        dsum = dfd + prod
        yy = dfd/dsum

        IF (yy>half) THEN
          xx = prod/dsum
          yy = one - xx
        ELSE
          xx = one - yy
        END IF

        betdn = cum_beta(x=xx,a=dfn*half+REAL(icent,kind=dpkind), &
          b=dfd*half,check_input=.FALSE.)

        adn = half*dfn + REAL(icent,kind=dpkind)
        aup = adn
        b = half*dfd
        betup = betdn
        sum = centwt*betdn

!     Now sum terms backward from icent until convergence or all done

        xmult = centwt
        i = icent
        dnterm = EXP(alngam(adn+b)-alngam(adn+one)-alngam(b)+adn*LOG(xx)+ &
          b*LOG(yy))

10      CONTINUE
        IF (qsmall(xmult*betdn) .OR. i<=0) GO TO 20
        xmult = xmult*(i/xnonc)
        i = i - 1
        adn = adn - 1
        dnterm = (adn+1)/((adn+b)*xx)*dnterm
        betdn = betdn + dnterm
        sum = sum + xmult*betdn
        GO TO 10

20      CONTINUE
        i = icent + 1

!     Now sum forwards until convergence

        xmult = centwt
        IF (aup-one+b==0) THEN
          upterm = EXP((-alngam(aup))-alngam(b)+(aup-one)*LOG(xx)+b*LOG( &
            yy))
        ELSE
          upterm = EXP(alngam(aup-one+b)-alngam(aup)-alngam(b)+ &
            (aup-one)*LOG(xx)+b*LOG(yy))
        END IF

        GO TO 40

30      CONTINUE
        IF (qsmall(xmult*betup)) GO TO 50

40      CONTINUE
        xmult = xmult*(xnonc/i)
        i = i + 1
        aup = aup + 1
        upterm = (aup+b-2.0E0_dpkind)*xx/(aup-1)*upterm
        betup = betup - upterm
        sum = sum + xmult*betup
        GO TO 30

50      CONTINUE
        cum = sum

        ccum = half + (half-cum)
        RETURN

      CONTAINS

!.....................................................................

        FUNCTION qsmall(x)
! .. Function Return Value ..
          LOGICAL :: qsmall
! ..
! .. Scalar Arguments ..
          REAL (dpkind) :: x
! ..
          qsmall = sum < 1.0E-20_dpkind .OR. x < eps*sum

          RETURN

        END FUNCTION qsmall

!.....................................................................

      END SUBROUTINE local_cum_nc_f

!*********************************************************************

    END MODULE cdf_nc_f_mod


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine intersectionpoint(pa,pb,xcp,t,xinters)
!
      implicit none
!
      integer k
!
      real*8 pa(*),pb(*),xcp(*),t,xinters(*),diff,pab(3),
     &     eplane,tnull
!
      do k=1,3
         pab(k)=pb(k)-pa(k)
       enddo
!
      diff=0.d0
      tnull=0.d0
!
      if(abs(eplane(pab,xcp,tnull)).lt.1.d-13)then
         write(*,*) 'SH: IP no intersection point can be found'
         write(*,*) 'SH: IP pab paralell to plane! '
         call exit(201)
      else
         diff=-eplane(pa,xcp,t)/eplane(pab,xcp,tnull)
      endif
      do k=1,3
         xinters(k)=pa(k)+diff*pab(k)
      enddo
      return
      end


      module MOD_PRIFLUX
      contains
C**********  MODULNAME: PRIFLUX   ******* 06/08/87  20.14.39.******   104 KARTEN
      SUBROUTINE PRIFLUX (NF,XLAMBDA,EMFLUX,TOTIN,TOTOUT,RSTAR,JOBNUM,
     $                    FWEIGHT,MODHEAD,AKEY )
C***********************************************************************
C***   PRINTOUT OF THE EMERGENT CONTINUUM FLUX
C***   called by
C***********************************************************************
      use MOD_TRADFUN
      use MOD_BNUE
      use MOD_TCOLOR
      use MOD_PRICOLR
      use CONSTANTS,only:CLIGHT_CGS,PI
      implicit real*8(a-h,o-z)

      DIMENSION XLAMBDA(NF),EMFLUX(NF),FWEIGHT(NF),AKEY(NF)
      CHARACTER MODHEAD*104, IFSUM*8, JUMP*8, ITCOL*8
	character*5  CEDGE

C***  STEBOL = STEFAN-BOLTZMANN CONSTANT / PI  (ERG/CM**2/S/STERAD/KELVIN**4)
      DATA STEBOL / 1.804696d-5 /
C***  HC = H * C  ( ERG * ANGSTROEM )
      DATA HC / 1.9864837d-8/

      PRINT 1,MODHEAD,JOBNUM
    1 FORMAT (10H1$$$$$$$$$,/,1X,  A104,  20X,'JOB NO.',I5,
     $//,30X,'E M E R G E N T  A S T R O P H Y S I C A L  F L U X',/,30X
     $,51('='),/,34X,43H( FLUX = PI * ASTROPHYS.FLUX = 4 * PI * H ),//,
     $ ' FREQUENCY      LAMBDA    LOG F-NUE   LOG F-LAMBDA  ',
     $ '   T-RAD     T-COLOR    F-NUE /     LOG INTEGRATED F-NUE ',
     $ '  CONT. JUMP',
     $/,'   INDEX     (ANGSTROEM)  (ERG/CM+2) (ERG/CM+2/S/A) ',
     $ ' (KELVIN)    (KELVIN)    B(TEFF)    (ERG/CM2/SEC)    ',
     $ '    (MAGNITUDES)',/)

C***  CALCULATION OF EFFECTIVE TEMPERATURE
      TEFF=(TOTOUT /STEBOL)**.25
C***  CALCULATION OF LUMINOSITY
C***  THE NUMERICAL CONSTANT DENOTES THE LOG OF 4*PI*STEBOL/LSOLAR
      ALUMI=2.d0*LOG10(RSTAR*TEFF*TEFF)-36.730d0

      FSUM=.0d0
C***  LOOP OVER ALL FREQUENCY POINTS  ----------------------------------
!	OPEN (UNIT=1, FILE="flux2.out",FORM="FORMATTED")
      DO 2 K=1,NF
      XLAM=XLAMBDA(K)
      FK=EMFLUX(K)
      W=1.d8/XLAM
      IF (FK .LE. .0) THEN
            FNUE=.0
            FLAMBDA=.0
            ELSE
            FNUE=LOG10(FK)
            FLAMBDA=FNUE+LOG10(CLIGHT_CGS*W/XLAM)
            ENDIF
      TRAD=TRADFUN(XLAM,FK)
C***  CALCULATION OF TCOLOR FROM THE SLOPE OF EMFLUX BETWEEN K-1 AND K
      ITCOL='        '
      IF (K.GT.1) THEN
         CALL TCOLOR (XLAMBDA(K-1),XLAM,EMFLUX(K-1),FK,ITCOL)
         ENDIF
      FOVERB=FK/BNUE(XLAM,TEFF)
C***  INTEGRATION OF F-NUE FROM ZERO TO CURRENT WAVELENGTH
      FSUM=FSUM+FK*FWEIGHT(K)
      IF (FSUM .GT. 1.d-99 .AND. FSUM .LT. 1.d+99) THEN
         FSUMLOG=LOG10(FSUM)
         write (IFSUM,5) FSUMLOG
    5    FORMAT (F8.3)
         ELSE
         FSUMLOG=-99.
         FSUM=0.
         IFSUM='    -INF'
         ENDIF
C***  CONTINUUM JUMPS AT EDGE FREQUENCIES
      JUMP='        '
c      READ (AKEY(K),99) NEDGE
      decode (5,99,akey(k)) AEDGE
   99 FORMAT (A5)
c	print 99,aedge
c      IF (NEDGE .EQ. 'EDGE+') THEN
c*** by writing out AKEY in ASCII a bit can get lost
c      if (AEDGE .eq. 5HEDGE+.or.AEDGE.eq.5HFDGE+) then
	write (CEDGE,99) AEDGE
      if (CEDGE(2:5) .eq. 'DGE+') then
         IF (EMFLUX(K-1) .LE. .0 .OR. EMFLUX(K) .LE. .0) THEN
            JUMP='   UNDEF'
            ELSE
            write (JUMP,8) LOG10(EMFLUX(K)/EMFLUX(K-1))*2.5
    8       FORMAT (F8.3)
            ENDIF
         ENDIF
c	write (1,*) xlam,fnue,flambda,TRAD,ITCOL,FOVERB,IFSUM,JUMP
!	write (1,*) xlam,fnue,flambda
    2 PRINT 3, K,XLAM,FNUE,FLAMBDA,TRAD,ITCOL,FOVERB,IFSUM,JUMP
    3 FORMAT (I7,F15.2,2F13.3,F12.0,4X,A8,G14.3,6X,A8,10X,A8)
!	close (unit=1)
C***  ENDLOOP  ---------------------------------------------------------

C***  CALCULATION OF H-LYMAN PHOTONS
      SNNUE=.0
      SINUE=.0
      DO 6 K=1,NF
      EMFLW=EMFLUX(K)*FWEIGHT(K)
      ANNUE=EMFLW*XLAMBDA(K)/HC
      SNNUE=SNNUE+ANNUE
      SINUE=SINUE+EMFLW
      IF (XLAMBDA(K) .LT. 911.55 ) THEN
         SNALF=SNNUE
         KMAX=K
      ENDIF
    6 CONTINUE
    7 CONTINUE
      IF (SNNUE .GT. 1.d-99 .AND. SNNUE .LT. 1.d+99) THEN
      XLAMMAX=(XLAMBDA(KMAX)+XLAMBDA(KMAX+1))*.5
C*** TEMPERATURE DEFINITION OF KRIS DAVIDSON APJ 317,760
      T0=SINUE/SNNUE/2.701178033d0/1.38062259d-16
      PRINT 44,SINUE,SNNUE,T0
   44 FORMAT(/,10X,'ASTROPHYSICAL-FLUX-INTEGRAL:',1PE10.3,10X,
     $             'PHOTONS:',E10.3,10X,'T0:',0PF8.0)
      ENDIF
      IF (SNALF .GT. 1.d-99 .AND. SNALF .LT. 1.d+99) THEN
      SNALF=LOG10(4.*PI*PI*RSTAR*RSTAR*SNALF)
      ELSE
      SNALF=-99.
      ENDIF

      PRINT 4,TEFF,ALUMI,SNALF,XLAMMAX,TOTIN/TOTOUT
    4 FORMAT (/,10X,'EFFECTIVE TEMPERATURE:',F8.0,' KELVIN ',
     $            20X,'NUMBER OF H-LYMAN PHOTONS PER SECOND:',/,
     $          10X,'LOG OF LUMINOSITY (SOLAR UNITS):',F7.3,
     $            19X,'LOG(N)=',F6.2,'  (INTEGRATED UP TO',F7.2,
     $            ' ANGSTROEM)',/,
     $          10X,'RADIATIVE ENERGY INPUT/OUTPUT:',F8.3)

      CALL PRICOLR (NF,XLAMBDA,EMFLUX,RSTAR)

      RETURN
      END subroutine
      end module


*DECK BETA
      FUNCTION BETA (A, B)
C***BEGIN PROLOGUE  BETA
C***PURPOSE  Compute the complete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      SINGLE PRECISION (BETA-S, DBETA-D, CBETA-C)
C***KEYWORDS  COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BETA computes the complete beta function.
C
C Input Parameters:
C       A   real and positive
C       B   real and positive
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALBETA, GAMLIM, GAMMA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  BETA
      EXTERNAL GAMMA
      SAVE XMAX, ALNSML
      DATA XMAX, ALNSML /0., 0./
C***FIRST EXECUTABLE STATEMENT  BETA
      IF (ALNSML.NE.0.0) GO TO 10
      CALL GAMLIM (XMIN, XMAX)
      ALNSML = LOG(R1MACH(1))
C
 10   IF (A .LE. 0. .OR. B .LE. 0.) CALL XERMSG ('SLATEC', 'BETA',
     +   'BOTH ARGUMENTS MUST BE GT 0', 2, 2)
C
      IF (A+B.LT.XMAX) BETA = GAMMA(A) * GAMMA(B) / GAMMA(A+B)
      IF (A+B.LT.XMAX) RETURN
C
      BETA = ALBETA (A, B)
      IF (BETA .LT. ALNSML) CALL XERMSG ('SLATEC', 'BETA',
     +   'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 2)
C
      BETA = EXP (BETA)
C
      RETURN
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by ucar                 .
c  .                                                             .
c  .       university corporation for atmospheric research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         spherepack3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file gaqd.f
c
c     this file includes documentation and code for subroutine gaqd.
c
c     modified on april 14, 1999 based on an observation by R. Loft
c     that reduces both storage and compute time by a factor of nlat!
c
c ... required files
c
c     none
c
c     subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror)
c
c     subroutine gaqd computes the nlat gaussian colatitudes and weights
c     in double precision. the colatitudes are in radians and lie in the
c     in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     dwork   a double precision temporary work space.
c
c     ldwork  the length of the work space  in the routine calling gaqd
c             ldwork must be at least nlat.
c
c     output parameters
c
c     theta   a double precision vector of length nlat containing the
c             nlat gaussian colatitudes on the sphere in increasing radians
c             in the interval (0,pi).
c
c             the accuracy of the theta array can be improvred by calling
c             subroutine gpnewt
c
c     wts     a double precision vector of length nlat containing the
c             nlat gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if ldwork.lt.nlat
c            = 2 if nlat.le.0
c            = 3 if unable to compute gaussian points
c                (failure in in the eigenvalue routine)
c
c  *****************************************************************
      subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror)
      double precision theta(nlat),wts(nlat),dwork(nlat),x
      n = nlat
      ierror = 1
c     check work space length
      if (ldwork .lt. n) return
      ierror = 2
      if (n.le.0) return
      ierror = 0
      if (n.gt.2) then
c
      call gaqd1(n,theta,wts,dwork,ierror)
      if (ierror.ne.0) then
      ierror = 3
      return
      end if
      return
      else if (n.eq.1) then
      wts(1) = 2.0d0
      theta(1) = dacos(0.0d0)
      else if (n.eq.2) then
c     compute weights and points analytically when n=2
      wts(1) = 1.0d0
      wts(2) = 1.0d0
      x = dsqrt(1.0d0/3.0d0)
      theta(1) = dacos(x)
      theta(2) = dacos(-x)
      return
      end if
      end
      subroutine gaqd1(n,theta,wts,e,ier)
      dimension theta(n),wts(n),e(n)
      double precision theta,wts,e
c     set symmetric tridiagnonal matrix subdiagonal and diagonal
c     coefficients for matrix coming from coefficients in the
c     recursion formula for legendre polynomials
c     a(n)*p(n-1)+b(n)*p(n)+c(n)*p(n+1) = 0.
      theta(1) = 0.d0
      e(1) = 0.d0
      do 100 j=2,n
      e(j)= (j-1.d0)/dsqrt((2.d0*j-1.d0)*(2.d0*j-3.d0))
      theta(j) = 0.d0
  100 continue
c
c     compute eigenvalues and first elemnt of the eigenvectors
c
      call gaqd2(n,theta,e,wts,ier)
      if (ier.ne.0) return
c

      do 102 i=1,n
      theta(i) = -theta(i)
c      theta(n-i+1) = -theta(i)
  102 continue
      if(mod(n,2).ne.0) theta(n/2+1) = 0.d0
c
c     compute gaussian weights and points
c

      do 101 j=1,n
      theta(j) = dacos(theta(j))
c
c     set gaussian weights as 1st components of eigenvectors squared
c
      wts(j) = 2.0d0*wts(j)**2
  101 continue
c
c     reverse order of gaussian points to be
c     monotonic increasing in radians
c
      return
      end
      subroutine gaqd2(n,w,e,z,ierr)
c     drst is a double precision modification of rst off eispack
c     to be used  to compute gaussian points and weights

c
      integer i,n,ierr
      double precision w(n),e(n),z(n)

c
c     .......... find both eigenvalues and eigenvectors ..........
   20 do 40 i = 2, n
         z(i) = 0.0d0
   40 continue
      z(1) = 1.0d0
c
      call  gaqd3(n,w,e,z,ierr)
      return
      end
      subroutine gaqd3(n,d,e,z,ierr)
c
c     dintql is a modification of intql2 in eispack that
c     is used by gaqd in spherepack for computing
c     gaussian weights and points
c
      integer i,j,k,l,m,n,ii,mml,ierr
      double precision d(n),e(n),z(n)
      double precision b,c,f,g,p,r,s,tst1,tst2,dpytha
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      e(n) = 0.0d0
c
      do 240 l = 1, n
	 j = 0
c     .......... look for small sub-diagonal element ..........
c
  105    nm1 = n-1
         if(l .gt. nm1) go to 111
         do 110 mdo = l, nm1
            m = mdo
	    tst1 = dabs(d(m)) + dabs(d(m+1))
	    tst2 = tst1 + dabs(e(m))
	    if (tst2 .eq. tst1) go to 120
  110    continue
  111    m = n
c
  120    p = d(l)
	 if (m .eq. l) go to 240
	 if (j .eq. 30) go to 1000
	 j = j + 1
c     .......... form shift ..........
	 g = (d(l+1) - p) / (2.0d0 * e(l))
	 r = dpytha(g,1.0d0)
	 g = d(m) - p + e(l) / (g + sign(r,g))
	 s = 1.0d0
	 c = 1.0d0
	 p = 0.0d0
	 mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
	 do 200 ii = 1, mml
	    i = m - ii
	    f = s * e(i)
	    b = c * e(i)
	    r = dpytha(f,g)
	    e(i+1) = r
	    if (r .eq. 0.0d0) go to 210
	    s = f / r
	    c = g / r
	    g = d(i+1) - p
	    r = (d(i) - g) * s + 2.0d0 * c * b
	    p = s * r
	    d(i+1) = g + p
	    g = c * r - b
c     .......... form vector ..........
            f = z(i+1)
            z(i+1) = s * z(i) + c * f
            z(i) = c * z(i) - s * f
  200    continue
c
	 d(l) = d(l) - p
	 e(l) = g
	 e(m) = 0.0d0
	 go to 105
c     .......... recover from underflow ..........
  210    d(i+1) = d(i+1) - p
	 e(m) = 0.0d0
	 go to 105
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
	 i = ii - 1
	 k = i
	 p = d(i)
c
	 do 260 j = ii, n
	    if (d(j) .ge. p) go to 260
	    k = j
	    p = d(j)
  260    continue
c
	 if (k .eq. i) go to 300
	 d(k) = d(i)
	 d(i) = p
c
         p = z(i)
         z(i) = z(k)
         z(k) = p
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      double precision function dpytha(a,b)
      double precision a,b
c     dpytha is a double precision modification of pythag off eispack
c     for use by dimtql

c
c     finds sqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dabs(a)
      if (dabs(b).ge.dabs(a)) p = dabs(b)
      if (p .eq. 0.0d0) go to 20
      r = (dabs(a)/p)**2
      if (dabs(b).lt.dabs(a)) r = (dabs(b)/p)**2
   10 continue
	 t = 4.0d0 + r
	 if (t .eq. 4.0d0) go to 20
	 s = r/t
	 u = 1.0d0 + 2.0d0*s
	 p = u*p
	 r = (s/u)**2 * r
      go to 10
   20 dpytha = p
      return
      end
      subroutine gpnewt(n,theta,work)
c
c     one newton iteration to correct the gauss points
c     computed by subroutine gaqd
c
c     calls subroutines dnlfk, dnlft, and dnlftd in file
c     ~/codes/packages/spherepack/sphpk3/sphcom.f
c
      double precision theta(n),work(5*n/2+2)
c
      call gpnewt1(n,theta,work,work(n+1),work(2*n+1))
      return
      end
      subroutine gpnewt1(n,theta,pb,dpb,cp)
      double precision theta(n),pb(n),dpb(n),cp(n/2+2)
c
      call dnlfk (0,n,cp)
      do i=1,n
      call dnlft (0,n,theta(i),cp,pb(i))
      call dnlftd (0,n,theta(i),cp,dpb(i))
      end do
      do i=1,n
      theta(i) = theta(i)-pb(i)/dpb(i)
      end do
      return
      end
c     subroutine dnlfk(m,n,cp)
c
c     subroutine dnlfk computes the coefficients in the trigonometric
c     expansion of the normalized associated legendre functions:
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                        *sin(theta)**m/(2**n*factorial(n)) times the
c                        (n+m)th derivative of (x**2-1)**n with respect
c                        to x=cos(theta)
c
c     where theta is colatitude.
c
c     subroutine dnlfk computes the coefficients cp(k) in the
c     following trigonometric expansion of pbar(m,n,theta).
c
c            1) for n even and m even, pbar(m,n,theta) =
c               .5*cp(1) plus the sum from k=1 to k=n/2
c               of cp(k)*cos(2*k*th)
c
c            2) for n even and m odd, pbar(m,n,theta) =
c               the sum from k=1 to k=n/2 of
c               cp(k)*sin(2*k*th)
c
c            3) for n odd and m even, pbar(m,n,theta) =
c               the sum from k=1 to k=(n+1)/2 of
c               cp(k)*cos((2*k-1)*th)
c
c            4) for n odd and m odd,  pbar(m,n,theta) =
c               the sum from k=1 to k=(n+1)/2 of
c               cp(k)*sin((2*k-1)*th)
c
c     input parameters
c
c     m      is the order of pbar(n,m,theta). m can be any integer
c            however pbar(n,m,theta) = 0  if abs(m) is greater than
c            n and pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta) for
c            negative m.
c
c     n      nonnegative integer specifying the degree of
c            pbar(n,m,theta)
c
c     output parameters
c
c     cp     a double precision array that contains the fourier
c            coefficients for pbar(m,n,theta). the length of the
c            array depends on the parity of m and n
c
c                  parity            length of cp
c
c               n even m even           n/2+1
c               n even m odd             n/2
c               n odd  m even          (n+1)/2
c               n odd  m odd           (n+1)/2
c
c
c ****************************************************************
      subroutine dnlfk (m,n,cp)
c
      double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk,
     1       t1,t2,pm1,sc10,sc20,sc40
      dimension       cp(1)
      parameter (sc10=1024.d0)
      parameter (sc20=sc10*sc10)
      parameter (sc40=sc20*sc20)
c
      cp(1) = 0.
      ma = iabs(m)
      if(ma .gt. n) return
      if(n-1) 2,3,5
    2 cp(1) = dsqrt(2.d0)
      return
    3 if(ma .ne. 0) go to 4
      cp(1) = dsqrt(1.5d0)
      return
    4 cp(1) = dsqrt(.75d0)
      if(m .eq. -1) cp(1) = -cp(1)
      return
    5 if(mod(n+ma,2) .ne. 0) go to 10
      nmms2 = (n-ma)/2
      fnum = n+ma+1
      fnmh = n-ma+1
      pm1 = 1.d0
      go to 15
   10 nmms2 = (n-ma-1)/2
      fnum = n+ma+2
      fnmh = n-ma+2
      pm1 = -1.d0
c      t1 = 1.
c      t1 = 2.d0**(n-1)
c      t1 = 1.d0/t1
 15   t1 = 1.d0/sc20
      nex = 20
      fden = 2.d0
      if(nmms2 .lt. 1) go to 20
      do 18 i=1,nmms2
      t1 = fnum*t1/fden
      if(t1 .gt. sc20) then
      t1 = t1/sc40
      nex = nex+40
      end if
      fnum = fnum+2.
      fden = fden+2.
   18 continue
   20 t1 = t1/2.d0**(n-1-nex)
      if(mod(ma/2,2) .ne. 0) t1 = -t1
      t2 = 1.
      if(ma .eq. 0) go to 26
      do 25 i=1,ma
      t2 = fnmh*t2/(fnmh+pm1)
      fnmh = fnmh+2.
   25 continue
   26 cp2 = t1*dsqrt((n+.5d0)*t2)
      fnnp1 = n*(n+1)
      fnmsq = fnnp1-2.d0*ma*ma
      l = (n+1)/2
      if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1
      cp(l) = cp2
      if(m .ge. 0) go to 29
      if(mod(ma,2) .ne. 0) cp(l) = -cp(l)
   29 if(l .le. 1) return
      fk = n
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = 2.*(fk*fk-fnmsq)
      cp(l-1) = b1*cp(l)/a1
   30 l = l-1
      if(l .le. 1) return
      fk = fk-2.
      a1 = (fk-2.)*(fk-1.)-fnnp1
      b1 = -2.*(fk*fk-fnmsq)
      c1 = (fk+1.)*(fk+2.)-fnnp1
      cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
      go to 30
      end
      subroutine dnlft (m,n,theta,cp,pb)
      dimension cp(1)
      double precision cp,pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(abs(m),2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = .5*cp(1)
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb+cp(k+1)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb+cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end
      subroutine dnlftd (m,n,theta,cp,pb)
c
c     computes the derivative of pmn(theta) with respect to theta
c
      dimension cp(1)
      double precision cp,pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(abs(m),2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = 0.d0
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb-2.d0*k*cp(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+2.d0*k*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb-(2.d0*k-1)*cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+(2.d0*k-1)*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end


module points
TYPE POINT
  REAL :: X, Y

CONTAINS
procedure, PASS :: LENGTH => POINT_LENGTH
END TYPE POINT

type, extends (point) :: POINT_3D
  REAL :: Z
CONTAINS
procedure, PASS :: LENGTH => POINT_3D_LENGTH
END type   POINT_3D

contains

REAL FUNCTION POINT_LENGTH( A, B )
CLASS(POINT), INTENT(IN) :: A, B
POINT_LENGTH = SQRT((A%X - B%X)**2 + (A%Y - B%Y)**2)
END FUNCTION POINT_LENGTH
REAL FUNCTION POINT_3D_LENGTH(A, B)
CLASS (POINT_3D), INTENT (IN) :: A
class(point), intent (in) :: B
SELECT TYPE (B)
  CLASS is (POINT_3D)
END select
END FUNCTION point_3d_length
END module points