cc Copyright (C) 2017: Travis Askham
cc email: askhamwhat@gmail.com
cc
cc This software is being released under a modified FreeBSD license
cc (see licenses folder in home directory).

      subroutine modbhgreen_all(beta,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates the Green function
c
c     G(x,y) = (S_beta(r) - S_0(r))/beta^2 ,
c
c     where S_beta is the fundamental solution of the Yukawa equation
c     and S_0 is the fundamental solution of the Laplace equation and
c     r = sqrt( (x_1-y_1)^2 + (x_2-y_2)^2),
c     and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     INPUTS
c
c     beta - real *8, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c     ifder3 - if equal to 1, compute 3rd order derivatives
c     ifder4 - if equal to 1, compute 4th order derivatives
c     ifder5 - if equal to 1, compute 5th order derivatives
c
c     OUTPUTS
c
c     note: for derivatives, the ordering is such that,
c     for a given order, the first entry has all of the
c     derivatives on the x1 variables, the second entry
c     has one derivative on the x2 variable and the rest
c     on x1, and so on. e.g.
c
c     hess(1) = d_x1 d_x1 G(x,y)
c     hess(2) = d_x1 d_x2 G(x,y)
c     hess(3) = d_x2 d_x2 G(x,y)
c
c     pot - real *8, potential, if requested
c     grad(2) - real *8, gradient, if requested
c     hess(3) - real *8, hessian, if requested
c     der3(4) - real *8, 3rd order derivatives, if requested.
c     der4(5) - real *8, 4th order derivatives, if requested.
c     der5(6) - real *8, 5th order derivatives, if requested.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 beta, zx(2), zy(2), pot, grad(2), hess(3)
      real *8 der3(4), der4(5), der5(6)
      integer ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
c     local variables
      real *8 dx, dy, r, r2, r3, r4, r5, r6
      real *8 dx2, dx3, dx4, dx5, dy2, dy3, dy4, dy5
      real *8 g0, g1, g2, g3, g4, g5, betah, dtemp
      real *8 g0temp, g1temp, g2temp, g3temp
      integer if1, if2, if3, if0, ifders
      real *8 diffs(0:5), rscale, pih
      integer nmax, ifder, j
      complex *16 z, eye, hvec(0:10), hder(0:10)
      real *8 kvec(0:10), ders(0:5)
      data eye /(0.0d0,1.0d0)/

      dx = zx(1) - zy(1)
      dy = zx(2) - zy(2)

      dx2 = dx*dx
      dx3 = dx2*dx
      dx4 = dx3*dx
      dx5 = dx4*dx
      dy2 = dy*dy
      dy3 = dy2*dy
      dy4 = dy3*dy
      dy5 = dy4*dy

      r2 = dx2 + dy2
      r = dsqrt(r2)
      r3 = r2*r
      r4 = r3*r
      r5 = r4*r

      nmax = 5

c     get values of difference kernel and higher modes

      rscale = 1.0d0
      ifders = 0
c      call diffslogbk(r,beta,rscale,diffs,nmax)
      call diffslogbk_fast(r,beta,rscale,diffs,ifders,ders,kvec,nmax)

c     get values of modified Bessel functions

      z = eye*r*beta
      ifder = 0
      rscale = 1.0d0
c      call h2dall(nmax,z,rscale,hvec,ifder,hder)

      pih = 2.0d0*atan(1.0d0)

c      kvec(0) = -dimag(hvec(0))*pih
c      kvec(1) = -dreal(hvec(1))*pih
c      kvec(2) = dimag(hvec(2))*pih
c      kvec(3) = dreal(hvec(3))*pih

c     combine to get values of derivatives of G
c     with respect to r

      dtemp = 1.0d0/(4.0d0*pih*beta**2)
      betah = 0.5d0*beta

      g0 = diffs(0)*dtemp
      dtemp = -dtemp*beta
      g1 = diffs(1)*dtemp
      dtemp = -dtemp*betah
      g2 = (diffs(2)+kvec(0))*dtemp
      dtemp = -dtemp*betah
      g3 = (diffs(3)+3.0d0*kvec(1))*dtemp
      dtemp = -dtemp*betah
      g4 = (diffs(4)+3.0d0*kvec(0)+4.0d0*kvec(2))*dtemp
      dtemp = -dtemp*betah
      g5 = (diffs(5)+10.0d0*kvec(1)+5.0d0*kvec(3))*dtemp

      if0 = 1
      if1 = 1
      if2 = 1
      if3 = 1
c      call difflogbk(r,beta,if0,g0temp,if1,g1temp,if2,g2temp,if3,g3temp)

c      write(*,*) g0, g0temp/(4.0d0*pih*beta**2)
c      write(*,*) g1, g1temp/(4.0d0*pih*beta**2)
c      write(*,*) g2, g2temp/(4.0d0*pih*beta**2)
c      write(*,*) g3, g3temp/(4.0d0*pih*beta**2)
c      write(*,*) g4
c      write(*,*) g5

c     evaluate potential and derivatives

      if (ifpot .eq. 1) then
         pot = g0
      endif

      if (ifgrad .eq. 1) then
         grad(1) = dx*g1/r
         grad(2) = dy*g1/r
      endif

      if (ifhess .eq. 1) then
         hess(1) = dx2*g2/r2+g1*(1.0d0/r-dx2/r3)
         hess(2) = dx*dy*(g2/r2-g1/r3)
         hess(3) = dy2*g2/r2+g1*(1.0d0/r-dy2/r3)
      endif

      if (ifder3 .eq. 1) then
         der3(1) = (dx3*g3+3.0d0*dy2*dx*(g2/r-g1/r2))/r3
         der3(2) = dx2*dy*(g3/r3-3.0d0*(g2/r4-g1/r5)) +
     1        dy*(g2/r2-g1/r3)
         der3(3) = dx*dy2*(g3/r3-3.0d0*(g2/r4-g1/r5)) +
     1        dx*(g2/r2-g1/r3)
         der3(4) = (dy3*g3+3.0d0*dx2*dy*(g2/r-g1/r2))/r3
      endif

      if (ifder4 .eq. 1) then
         der4(1) = (dx4*(g4-6.0d0*g3/r+15.0d0*(g2/r2-g1/r3)))/r4 +
     1        (dx2*6.0d0*(g3-3.0d0*(g2/r-g1/r2)))/r3 +
     2        (3.0d0*(g2-g1/r))/r2
         der4(2) = (dx3*dy*(g4-6.0d0*g3/r+15.0d0*(g2/r2-g1/r3)))/r4 +
     1        (3.0d0*dx*dy*(g3-3.0d0*(g2/r-g1/r2)))/r3
         der4(3) = dx2*dy2*(g4-6.0d0*g3/r+15.0d0*g2/r2-15.0d0*g1/r3)/r4
     1        + g3/r - 2.0d0*g2/r2 + 2.0d0*g1/r3
         der4(4) = dx*dy3*(g4-6.0d0*g3/r+15.0d0*(g2/r2-g1/r3))/r4 +
     1        3.0d0*dx*dy*(g3-3.0d0*(g2/r-g1/r2))/r3
         der4(5) = dy4*(g4-6.0d0*g3/r+15.0d0*(g2/r2-g1/r3))/r4 +
     1        dy2*6.0d0*(g3-3.0d0*(g2/r-g1/r2))/r3 +
     2        3.0d0*(g2-g1/r)/r2
      endif

      if (ifder5 .eq. 1) then
         der5(1) = (dx5*g5+10.0d0*dy2*dx3*g4/r +
     1        (15.0d0*dy4*dx-30.0d0*dy2*dx3)*g3/r2 +
     2        (60.0d0*dy2*dx3-45.0d0*dy4*dx)*g2/r3 +
     3        (45.0d0*dy4*dx-60.0d0*dy2*dx3)*g1/r4)/r5
         der5(2) = (dy*dx4*g5+(6.0d0*dy3*dx2-4.0d0*dy*dx4)*g4/r +
     1        (3.0d0*dy5+12.0d0*dy*dx4-30.0d0*dy3*dx2)*g3/r2 +
     2        (72.0d0*dy3*dx2-9.0d0*dy5-24.0d0*dy*dx4)*g2/r3 +
     3        (9.0d0*dy5-72.0d0*dy3*dx2+24.0d0*dy*dx4)*g1/r4)/r5
         der5(3) = (dy2*dx3*g5+(3.0d0*dy4*dx-6.0d0*dy2*dx3+dx5)*g4/r +
     1        (27.0d0*dy2*dx3-15.0d0*dy4*dx-3.0d0*dx5)*g3/r2 +
     2        (36.0d0*dy4*dx-63.0d0*dy2*dx3+6.0d0*dx5)*g2/r3 +
     3        (63.0d0*dy2*dx3-36.0d0*dy4*dx-6.0d0*dx5)*g1/r4)/r5
         der5(4) = (dx2*dy3*g5+(3.0d0*dx4*dy-6.0d0*dx2*dy3+dy5)*g4/r +
     1        (27.0d0*dx2*dy3-15.0d0*dx4*dy-3.0d0*dy5)*g3/r2 +
     2        (36.0d0*dx4*dy-63.0d0*dx2*dy3+6.0d0*dy5)*g2/r3 +
     3        (63.0d0*dx2*dy3-36.0d0*dx4*dy-6.0d0*dy5)*g1/r4)/r5
         der5(5) = (dx*dy4*g5+(6.0d0*dx3*dy2-4.0d0*dx*dy4)*g4/r +
     1        (3.0d0*dx5+12.0d0*dx*dy4-30.0d0*dx3*dy2)*g3/r2 +
     2        (72.0d0*dx3*dy2-9.0d0*dx5-24.0d0*dx*dy4)*g2/r3 +
     3        (9.0d0*dx5-72.0d0*dx3*dy2+24.0d0*dx*dy4)*g1/r4)/r5
         der5(6) = (dy5*g5+10.0d0*dx2*dy3*g4/r +
     1        (15.0d0*dx4*dy-30.0d0*dx2*dy3)*g3/r2 +
     2        (60.0d0*dx2*dy3-45.0d0*dx4*dy)*g2/r3 +
     3        (45.0d0*dx4*dy-60.0d0*dx2*dy3)*g1/r4)/r5
      endif

      return
      end

      subroutine modbhgreen(beta,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates the Green's function (S_beta - S_0)/beta^2
c     and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     INPUTS
c
c     beta - real *8, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - real *8, potential, if requested
c     grad(2) - real *8, gradient, if requested
c     hess(3) - real *8, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 beta, zx(2), zy(2), pot, grad(2), hess(3)
      integer ifpot, ifgrad, ifhess
c     local variables
      real *8 der3(4), der4(5), der5(6)
      integer ifder3, ifder4, ifder5

      ifder3 = 0
      ifder4 = 0
      ifder5 = 0

      call modbhgreen_all(beta,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

      return
      end

      subroutine modbhgreend1(beta,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,dir1)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates a directional derivative of the Green's function
c     G = (S_beta - S_0)/beta^2 at the source ("y" variable)
c     and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     The potential is (nabla_y * dir1) G
c     The gradient is grad_x (nabla_y * dir1) G
c     The hessian is hess_x (nabla_y * dir1) G
c
c     INPUTS
c
c     beta - real *8, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - real *8, potential, if requested
c     grad(2) - real *8, gradient, if requested
c     hess(3) - real *8, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 beta, zx(2), zy(2), pot, grad(2), hess(3), dir1(2)
      integer ifpot, ifgrad, ifhess
c     local variables
      real *8 potloc, gradloc(2), hessloc(3), der3(4), der4(5)
      real *8 der5(6)
      integer ifder3, ifder4, ifder5, ifpotloc, ifgradloc, ifhessloc

      ifpotloc = 0
      ifgradloc = 0
      ifhessloc = 0
      ifder3 = 0
      ifder4 = 0
      ifder5 = 0

      if (ifpot .eq. 1) ifgradloc = 1
      if (ifgrad .eq. 1) ifhessloc = 1
      if (ifhess .eq. 1) ifder3 = 1

      call modbhgreen_all(beta,zx,zy,ifpotloc,potloc,ifgradloc,gradloc,
     1     ifhessloc,hessloc,ifder3,der3,ifder4,der4,ifder5,der5)

      if (ifpot .eq. 1) then
         pot = -dir1(1)*gradloc(1)-dir1(2)*gradloc(2)
      endif

      if (ifgrad .eq. 1) then
         grad(1) = -dir1(1)*hessloc(1) - dir1(2)*hessloc(2)
         grad(2) = -dir1(1)*hessloc(2) - dir1(2)*hessloc(3)
      endif

      if (ifhess .eq. 1) then
         hess(1) = -dir1(1)*der3(1) - dir1(2)*der3(2)
         hess(2) = -dir1(1)*der3(2) - dir1(2)*der3(3)
         hess(3) = -dir1(1)*der3(3) - dir1(2)*der3(4)
      endif

      return
      end

      subroutine modbhgreend2(beta,zx,zy,ifpot,pot,ifgrad,grad,
     1     ifhess,hess,dir1,dir2)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Evaluates the Green's function (S_beta - S_0)/beta^2
c     and its derivatives stably (with the derivatives on the
c     "x" or "target" variable).
c
c     INPUTS
c
c     beta - real *8, modified helmholtz parameter
c     zx(2) - real *8, coordinates of target
c     zy(2) - real *8, coordinates of source
c     ifpot - if equal to 1, compute potential
c     ifgrad - if equal to 1, compute gradient
c     ifhess - if equal to 1, compute hessian
c
c     OUTPUTS
c
c     pot - real *8, potential, if requested
c     grad(2) - real *8, gradient, if requested
c     hess(3) - real *8, hessian, if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 beta, zx(2), zy(2), pot, grad(2), hess(3), dir1(2)
      real *8 dir2(2)
      integer ifpot, ifgrad, ifhess
c     local variables
      real *8 r, r2, dx, dy, g0, g1, g2, g3, temp1, dx2, dy2
      real *8 r3, pi, r4, r5
      real *8 g, gx, gy, gxx, gxy, gyy, gxxx, gxxy, gxyy, gyyy
      real *8 gxxxx, gxxxy, gxxyy, gxyyy, gyyyy
      real *8 quadvec(3)
      integer if0, if1, if2, if3
      integer ifpot1,ifgrad1,ifhess1,ifder3,ifder4,ifder5
      real *8 potloc,gradloc(2),hessloc(3),der3(4),der4(5),der5(6)

      pi = 4.0d0*datan(1.0d0)

c     convert two directional derivatives to xx, xy, yy

      quadvec(1) = dir1(1)*dir2(1)
      quadvec(2) = dir1(1)*dir2(2) + dir1(2)*dir2(1)
      quadvec(3) = dir1(2)*dir2(2)

      ifpot1 = 0
      ifgrad1 = 0
      ifhess1 = 1
      ifder3 = 1
      ifder4 = 1
      ifder5 = 0

      call modbhgreen_all(beta,zx,zy,ifpot1,potloc,ifgrad1,gradloc,
     1     ifhess1,hessloc,ifder3,der3,ifder4,der4,ifder5,der5)

      if (ifpot .eq. 1) then
         pot = quadvec(1)*hessloc(1)+quadvec(2)*hessloc(2)
     1        +quadvec(3)*hessloc(3)
      endif

      if (ifgrad .eq. 1) then
         grad(1) = quadvec(1)*der3(1)+quadvec(2)*der3(2)
     1        +quadvec(3)*der3(3)
         grad(2) = quadvec(1)*der3(2)+quadvec(2)*der3(3)
     1        +quadvec(3)*der3(4)
      endif

      if (ifhess .eq. 1) then
         hess(1) = quadvec(1)*der4(1)+quadvec(2)*der4(2)
     1        +quadvec(3)*der4(3)
         hess(2) = quadvec(1)*der4(2)+quadvec(2)*der4(3)
     1        +quadvec(3)*der4(4)
         hess(3) = quadvec(1)*der4(3)+quadvec(2)*der4(4)
     1        +quadvec(3)*der4(5)
      endif

      return
      end

      subroutine difflogbk(x,beta,if0,g0,if1,g1,if2,g2,if3,g3)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     K_0(beta x) - (-log(x))                     (1)
c
c     where K_0 is the modified Bessel function.
c
c     INPUT
c
c     if0, if1, if2, if3 - integer, flags. If ifj = 1, then the jth
c                          x derivative of (1) is returned in the
c                          variable gj
c
c     x - real. Argument of the function as in (1)
c
c     beta - real. Yukawa parameter as in (1)
c
c     OUTPUT
c
c     g0, g1, g2, g3 - real. Values of the derivatives of the
c                      difference kernel (1), if requested
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 x, beta, g0, g1, g2, g3
      integer if0, if1, if2, if3
c     local variables
      real *8 yh, yh2, yh3, yh2p, lnyh, y
      real *8 betah, lnbetah
      real *8 i0, i1, i2, i3
      real *8 k0ps, k1ps, k2ps, k3ps
      real *8 k0, k1, k2, k3
      real *8 psi0, psi1, psi2, psi3
      real *8 dtemp, dfac2
      complex *16 z, zk(4)
      integer p
      real *8 gamma
      data gamma /0.5772156649015328606d+00/
      integer pmax
      data pmax / 12 /

      y = x*beta
      yh = 0.5d0*y
      yh2 = yh*yh
      yh3 = yh2*yh
      lnyh = dlog(yh)

      dfac2 = 1
      i0 = 1
      i1 = 1
      i2 = 1/2.0d0
      i3 = 1/6.0d0
      psi0 = -gamma
      psi1 = psi0+1/2.0d0
      psi2 = psi1+1/4.0d0
      psi3 = psi2+1/6.0d0
      k0ps = i0*psi0
      k1ps = i1*psi1
      k2ps = i2*psi2
      k3ps = i3*psi3

      yh2p = yh2
      do p = 1,pmax
         dtemp = yh2p/dfac2
         psi0 = psi0+1.0d0/p
         i0 = i0+dtemp
         k0ps = k0ps+dtemp*psi0

         dtemp = dtemp/(p+1)
         psi1 = psi0+0.5d0/(p+1)
         i1 = i1+dtemp
         k1ps = k1ps+dtemp*psi1

         dtemp = dtemp/(p+2)
         psi2 = psi1+0.5d0/(p+2)
         i2 = i2+dtemp
         k2ps = k2ps+dtemp*psi2

         dtemp = dtemp/(p+3)
         psi3 = psi2+0.5d0/(p+3)
         i3 = i3+dtemp
         k3ps = k3ps+dtemp*psi3

         yh2p = yh2p*yh2
         dfac2 = dfac2*(p+1)*(p+1)

      enddo

      i1 = yh*i1
      i2 = yh2*i2
      i3 = yh3*i3

      k0 = k0ps-lnyh*i0
      k1 = -yh*k1ps+lnyh*i1+1/y
      k2 = yh2*k2ps-lnyh*i2+0.5d0/yh2-0.5d0
      k3 = -yh3*k3ps+lnyh*i3+1/yh3-0.5d0/yh+0.25d0*yh

      betah = beta*0.5d0
      lnbetah = dlog(betah)

c     g0 = k0+log(x)
      g0 = k0ps-lnyh*(i0-1)-lnbetah

c     g1 = -beta*k1+1/x
      g1 = beta*(yh*k1ps-lnyh*i1)

c     g2 = beta^2/2*(k0+k2)-1/x^2
      g2 = beta**2*0.5d0*(k0ps+yh2*k2ps-lnyh*(i0+i2)-0.5d0)

c     g3 = -beta^3/4*(3*k1+k3)+2/x^3
      g3 = beta**3*(0.75d0*yh*k1ps+0.25d0*yh3*k3ps
     1             -lnyh*(0.75d0*i1+0.25d0*i3)
     2             -0.25d0/yh-0.25d0*0.25d0*yh)

      return
      end

      subroutine diffslogbk(x,beta,rscale,diffs,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     K_0(beta x) - (-log(x))                     (1)
c
c     where K_0 is the modified Bessel function.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 x, beta, diffs(0:n), rscale
      integer n
c     local variables
      real *8 yh, yh2, yhp, yh2p, lnyh, y, rscale2, rscalep
      real *8 betah, lnbetah
      real *8 i0, i1, i2, i3
      real *8 k0ps, k1ps, k2ps, k3ps
      real *8 k0, k1, k2, k3
      real *8 psitemp1, psitemp2
      real *8 dtemp, dfac2
      real *8 psi(60+1000), kps(0:1000), ips(0:1000)
      real *8 fac(0:1000)
      complex *16 z, zk(4), eye
      data eye / (0.0d0,1.0d0) /
      complex *16 hvec(0:1000), hder(0:1000)
      real *8 kvec(0:1000)
      integer p, j, isign, ifder
      real *8 gamma, pih
      data gamma /0.5772156649015328606d+00/
      integer pmax
      data pmax / 12 /

      y = x*beta
      yh = 0.5d0*y
      lnyh = dlog(yh)

      if ( yh .le. 1.0d0 ) then

         yh2 = yh*yh

         psi(1) = -gamma
         do j = 2,pmax+n+1
            psi(j) = psi(j-1)+1.0d0/(j-1)
         enddo

         do j = 0,n
            kps(j) = 0.0d0
            ips(j) = 0.0d0
            diffs(j) = 0.0d0
         enddo

         ips(0) = -1.0d0

         yh2p = 1.0d0
         do p = 0,pmax
            dtemp = yh2p
            psitemp1 = psi(p+1)
            do j = 0,n
               psitemp2 = psi(p+1+j)
               kps(j) = kps(j)+(psitemp1+psitemp2)*dtemp
               ips(j) = ips(j)+dtemp
               dtemp = dtemp/(j+p+1.0d0)
            enddo
            yh2p = yh2p*yh2/((p+1.0d0)**2)
         enddo

         yhp = yh
         isign = -1
         rscalep = rscale
         do j = 1,n
            diffs(j) = isign*(0.5d0*yhp*kps(j)-lnyh*ips(j)*yhp)*rscalep
            yhp = yh*yhp
            rscalep = rscalep*rscale
            isign = -isign
         enddo

         diffs(0) = 0.5d0*kps(0)-lnyh*ips(0)-log(0.5d0*beta)

         fac(0) = 1.0d0
         fac(1) = 1.0d0

         do j = 2,n
            fac(j) = j*fac(j-1)
         enddo

         rscale2 = rscale*rscale
         do j = 1,n
            dtemp = -0.5d0*(yh/rscale)**(2-j)*rscale2
            do p = 1,j-1
               diffs(j) = diffs(j)+fac(j-p-1)*dtemp/fac(p)
               dtemp = -dtemp*yh2
            enddo
         enddo

      else

         z = eye*y
         ifder = 0
         call h2dall(n+5,z,rscale,hvec,ifder,hder)

         pih = 2.0d0*atan(1.0d0)

         do j = 0,n+1,4
            kvec(j) = -dimag(hvec(j))*pih
            kvec(j+1) = -dreal(hvec(j+1))*pih
            kvec(j+2) = dimag(hvec(j+2))*pih
            kvec(j+3) = dreal(hvec(j+3))*pih
         enddo

         diffs(0) = kvec(0) + log(x)

         dfac2 = 1.0d0/yh

         dtemp = 1.0d0/y

         rscalep = rscale
         do j = 1,n
            diffs(j) = (kvec(j) - dtemp)*rscalep
            dtemp = dtemp*dfac2*j
            rscalep = rscalep*rscale
         enddo

      endif

      return
      end

      subroutine diffslogbk_fast(x,beta,rscale,diffs,ifders,ders,
     1     kvec,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     K_0(beta x) - (-log(x))                     (1)
c
c     where K_0 is the modified Bessel function.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 x, beta, diffs(0:n), rscale, ders(0:n), kvec(0:n+4)
      integer n, ifders
c     local variables
      real *8 yh, yh2, yhp, yh2p, lnyh, y, rscale2
      real *8 betah, lnbetah
      real *8 i0, i1, i2, i3
      real *8 k0ps, k1ps, k2ps, k3ps
      real *8 k0, k1, k2, k3
      real *8 psitemp1, psitemp2
      real *8 dtemp, dfac2
      real *8 psi(60+2), kps0, kps1, ips0, ips1
      real *8 diffsnp1
      complex *16 hvec(0:1000), hder(0:1000)
      complex *16 eye
      integer ifder
      data eye / (0.0d0,1.0d0) /
      real *8 fac(0:1000)
      complex *16 z, zk(4)
      integer p, j, isign
      real *8 gamma, pih
      data gamma /0.5772156649015328606d+00/

      integer pmax
      parameter (pmax = 12)
      real *8 coeffs0(0:pmax), coeffs1(0:pmax)

      data coeffs0 / -1.1544313298030657d0,
     1     0.84556867019693427d0,
     2     1.8455686701969343d0,
     3     2.5122353368636010d0,
     4     3.0122353368636010d0,
     5     3.4122353368636009d0,
     6     3.7455686701969344d0,
     7     4.0312829559112204d0,
     8     4.2812829559112204d0,
     9     4.5035051781334428d0,
     $     4.7035051781334429d0,
     1     4.8853233599516246d0,
     2     5.0519900266182916d0 /

      data coeffs1 /  -0.15443132980306573d0,
     1     1.3455686701969343d0,
     2     2.1789020035302675d0,
     3     2.7622353368636010d0,
     4     3.2122353368636007d0,
     5     3.5789020035302679d0,
     6     3.8884258130540772d0,
     7     4.1562829559112204d0,
     8     4.3923940670223320d0,
     9     4.6035051781334424d0,
     $     4.7944142690425338d0,
     1     4.9686566932849576d0,
     2     5.1289131035413682d0 /

      y = x*beta
      yh = 0.5d0*y
      yh2 = yh*yh
      lnyh = dlog(yh)
      betah = beta/2.0d0

      z = eye*y
      ifder = 0

      if (yh .gt. 1.0d0 .or. n .gt. 1 .or. ifders .eq. 1) then
         call h2dall(n+4,z,rscale,hvec,ifder,hder)
         pih = 2.0d0*atan(1.0d0)
         do j = 0,n+1,4
            kvec(j) = -dimag(hvec(j))*pih
            kvec(j+1) = -dreal(hvec(j+1))*pih
            kvec(j+2) = dimag(hvec(j+2))*pih
            kvec(j+3) = dreal(hvec(j+3))*pih
         enddo
      endif

      if (yh .le. 1.0d0) then

         kps0 = 0.0d0
         ips0 = -1.0d0
c         ips0 = 0.0d0
         kps1 = 0.0d0
         ips1 = 0.0d0

         yh2p = 1.0d0
         do p = 0,pmax
            kps0 = kps0+coeffs0(p)*yh2p
            ips0 = ips0+yh2p
            yh2p = yh2p/(p+1.0d0)
            kps1 = kps1+coeffs1(p)*yh2p
            ips1 = ips1+yh2p
            yh2p = yh2p*yh2/(p+1.0d0)
         enddo

          diffs(0) = 0.5d0*kps0-lnyh*ips0 - dlog(betah)
c         diffs(0) = 0.5d0*kps0-lnyh*ips0
c         diffs(0) = 0.5d0*kps0-lnyh*ips0 + dlog(x)
         diffs(1) = (lnyh*ips1*yh-0.5d0*yh*kps1)*rscale

      else

         diffs(0) = kvec(0) + dlog(x)

         dtemp = 1.0d0/y
         diffs(1) = kvec(1) - dtemp*rscale

      endif

      rscale2 = rscale*rscale

      dtemp = diffs(1)
      do j = 2,n
         if (dabs(dtemp) .lt. 1.0d-200) dtemp = 0.0d0
         dtemp = 2.0d0*(j-1.0d0)*dtemp*(rscale/y)
     1        + kvec(j-2)*rscale2
         diffs(j) = dtemp
      enddo

      if (ifders .eq. 1) then

         diffsnp1 = 2.0d0*n*diffs(n)*(rscale/y) + kvec(n-1)*rscale2
         betah = 0.5d0*beta

         ders(0) = -beta*diffs(1)/rscale

         do j = 1,n-1
            ders(j) = -betah*(diffs(j+1)/rscale+kvec(j-1)*rscale)
         enddo

         ders(n) = -betah*(diffsnp1/rscale+kvec(n-1)*rscale)

      endif

      return
      end

      subroutine diffszkik(x,beta,rscale,diffs,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     I_0(beta x) - 1                  (1)
c
c     (I_n(beta x) - beta^n x^n/ (2^n n!))/rscale^n
c
c     where I_0 is the modified Bessel function.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 x, beta, diffs(0:n), rscale
      integer n
c     local variables
      real *8 yh, yh2, yhp, yh2p, y
      real *8 dtemp
      real *8, allocatable :: ivals(:)
      complex *16, allocatable :: fjs(:)
      real *8 fjder(10)
      integer, allocatable :: iscale(:)
      complex *16 z, eye
      data eye / (0.0d0,1.0d0) /
      integer p, j, ifder, ntop, lwfjs, ier
      integer pmax
      data pmax / 12 /

      y = x*beta
      yh = 0.5d0*y

      if ( yh .le. 1.0d0 ) then

         yh2 = yh*yh

         do j = 0,n
            diffs(j) = 0.0d0
         enddo

         yh2p = yh2
         do p = 1,pmax
            dtemp = yh2p
            do j = 0,n
               diffs(j) = diffs(j) + dtemp
               dtemp = dtemp/(j+p+1.0d0)
            enddo
            yh2p = yh2p*yh2/((p+1.0d0)**2)
         enddo

         yh2p = 1.0d0
         do j = 0,n
            diffs(j) = yh2p*diffs(j)
            yh2p = yh2p*yh/rscale
         enddo

      else

         lwfjs = n + 5 + 4*n + 100

         allocate(fjs(0:lwfjs),iscale(lwfjs),ivals(0:n+5))

         z = eye*y
         ifder = 0
c         call jfuns2d(ier,n,z,rscale,fjs,ifder,fjder,
c     1	      lwfjs,iscale,ntop)
         call jbessel2d(n,z,rscale,fjs,ifder,fjder)

         do j = 0,n+1,4
            ivals(j) = dreal(fjs(j))
            ivals(j+1) = dimag(fjs(j+1))
            ivals(j+2) = -dreal(fjs(j+2))
            ivals(j+3) = -dimag(fjs(j+3))
         enddo

         diffs(0) = ivals(0) - 1.0d0

         dtemp = yh/rscale
         do j = 1,n
            diffs(j) = ivals(j) - dtemp
            dtemp = dtemp*yh/(rscale*(j+1))
         enddo

      endif

      return
      end

      subroutine diffszkik_fast(x,beta,rscale,diffs,ifders,ders,ivec,n)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This subroutine evaluates the difference kernel
c
c     I_0(beta x) - 1                  (1)
c
c     (I_n(beta x) - beta^n x^n/ (2^n n!))/rscale^n
c
c     where I_0 is the modified Bessel function.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
c     global variables
      real *8 x, beta, diffs(0:n), rscale, ders(0:n), ivec(0:n)
      integer n, ifders
c     local variables
      real *8 yh, yh2, yhp, yh2p, y, betah
      real *8 dtemp
      real *8, allocatable :: ivals(:)
      complex *16, allocatable :: fjs(:)
      real *8 fjder(10)
      integer, allocatable :: iscale(:)
      complex *16 z, eye
      data eye / (0.0d0,1.0d0) /
      integer p, j, ifder, ntop, lwfjs, ier
      integer pmax
      data pmax / 12 /

      y = x*beta
      yh = 0.5d0*y

      lwfjs = n + 5 + 4*n + 500

      allocate(fjs(0:lwfjs),iscale(lwfjs),ivals(0:n+5))

      z = eye*y
      ifder = 0
      if (abs(z) .gt. 300) then
         do j = 0,n+5
            fjs(j) = 0.0d0
         enddo
      else
c         call jfuns2d(ier,n+5,z,rscale,fjs,ifder,fjder,
c     1        lwfjs,iscale,ntop)
         call jbessel2d(n+5,z,rscale,fjs,ifder,fjder)
      endif

c      call prin2('fjs *',fjs,2*n+10)

      do j = 0,n+1,4
         ivals(j) = dreal(fjs(j))
         ivals(j+1) = dimag(fjs(j+1))
         ivals(j+2) = -dreal(fjs(j+2))
         ivals(j+3) = -dimag(fjs(j+3))
      enddo

      do j = 0,n
         ivec(j) = ivals(j)
      enddo

      if ( yh .le. 1.0d0 ) then

         yh2 = yh*yh

         do j = 0,n
            diffs(j) = 0.0d0
         enddo

         yh2p = yh2
         do p = 1,pmax
            dtemp = yh2p
            do j = 0,n
               diffs(j) = diffs(j) + dtemp
               if (dtemp .lt. 1.0d-200) dtemp = 0.0d0
               dtemp = dtemp/(j+p+1.0d0)
            enddo
            if (yh2p .lt. 1.0d-200) yh2p = 0.0d0
            yh2p = yh2p*yh2/((p+1.0d0)**2)
         enddo

         yh2p = 1.0d0
         do j = 0,n
            diffs(j) = yh2p*diffs(j)
            if (yh2p .lt. 1.0d-200) yh2p = 0.0d0
            yh2p = yh2p*yh/rscale
         enddo

         if (ifders .eq. 1) then

            betah = 0.5d0*beta
            ders(0) = beta*ivals(1)*rscale

            do j = 1,n
               ders(j) = betah*(diffs(j-1)/rscale+rscale*ivals(j+1))
            enddo
         endif

      else

         diffs(0) = ivals(0) - 1.0d0

         dtemp = yh/rscale
         do j = 1,n
            diffs(j) = ivals(j) - dtemp
            dtemp = dtemp*yh/(rscale*(j+1))
            if (dtemp .gt. 1.0d250) dtemp = 0.0d0
         enddo

         if (ifders .eq. 1) then

            betah = 0.5d0*beta
            ders(0) = beta*ivals(1)*rscale

            do j = 1,n
               ders(j) = betah*(diffs(j-1)/rscale+rscale*ivals(j+1))
            enddo
         endif

      endif

      return
      end


*DECK SNBSL
      SUBROUTINE SNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB)
C***BEGIN PROLOGUE  SNBSL
C***PURPOSE  Solve a real band system using the factors computed by
C            SNBCO or SNBFA.
C***LIBRARY   SLATEC
C***CATEGORY  D2A2
C***TYPE      SINGLE PRECISION (SNBSL-S, DNBSL-D, CNBSL-C)
C***KEYWORDS  BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C     SNBSL solves the real band system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by SNBCO or SNBFA.
C
C     On Entry
C
C        ABE     REAL(LDA, NC)
C                the output from SNBCO or SNBFA.
C                NC must be .GE. 2*ML+MU+1 .
C
C        LDA     INTEGER
C                the leading dimension of the array  ABE .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from SNBCO or SNBFA.
C
C        B       REAL(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B .
C                = nonzero   to solve  TRANS(A)*X = B , where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically, this indicates singularity,
C        but it is often caused by improper arguments or improper
C        setting of LDA.  It will not occur if the subroutines are
C        called correctly and if SNBCO has set RCOND .GT. 0.0
C        or SNBFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL SNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C             CALL SNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   800717  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SNBSL
      INTEGER LDA,N,ML,MU,IPVT(*),JOB
      REAL ABE(LDA,*),B(*)
C
      REAL SDOT,T
      INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1
C***FIRST EXECUTABLE STATEMENT  SNBSL
      M=MU+ML+1
      NM1=N-1
      LDB=1-LDA
      IF(JOB.NE.0)GO TO 50
C
C       JOB = 0 , SOLVE  A * X = B
C       FIRST SOLVE L*Y = B
C
        IF(ML.EQ.0)GO TO 30
        IF(NM1.LT.1)GO TO 30
          DO 20 K=1,NM1
            LM=MIN(ML,N-K)
            L=IPVT(K)
            T=B(L)
            IF(L.EQ.K)GO TO 10
              B(L)=B(K)
              B(K)=T
   10       CONTINUE
            MLM=ML-(LM-1)
            CALL SAXPY(LM,T,ABE(K+LM,MLM),LDB,B(K+1),1)
   20     CONTINUE
   30   CONTINUE
C
C       NOW SOLVE  U*X = Y
C
        DO 40 KB=1,N
          K=N+1-KB
          B(K)=B(K)/ABE(K,ML+1)
          LM=MIN(K,M)-1
          LB=K-LM
          T=-B(K)
          CALL SAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1)
   40   CONTINUE
      GO TO 100
   50 CONTINUE
C
C       JOB = NONZERO, SOLVE TRANS(A) * X = B
C       FIRST SOLVE  TRANS(U)*Y = B
C
        DO 60 K = 1, N
          LM = MIN(K,M) - 1
          LB = K - LM
          T = SDOT(LM,ABE(K-1,ML+2),LDB,B(LB),1)
          B(K) = (B(K) - T)/ABE(K,ML+1)
   60   CONTINUE
C
C       NOW SOLVE TRANS(L)*X = Y
C
        IF (ML .EQ. 0) GO TO 90
        IF (NM1 .LT. 1) GO TO 90
          DO 80 KB = 1, NM1
            K = N - KB
            LM = MIN(ML,N-K)
            MLM = ML - (LM - 1)
            B(K) = B(K) + SDOT(LM,ABE(K+LM,MLM),LDB,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
              T = B(L)
              B(L) = B(K)
              B(K) = T
   70       CONTINUE
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
      RETURN
      END


      SUBROUTINE cdfbin(which,p,q,s,xn,pr,ompr,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFBIN ( WHICH, P, Q, S, XN, PR, OMPR, STATUS, BOUND )
C               Cumulative Distribution Function
C                         BINomial distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the binomial
C     distribution given values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next four argument
C               values is to be calculated from the others.
C               Legal range: 1..4
C               iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
C               iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
C               iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
C               iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
C                    INTEGER WHICH
C
C     P <--> The cumulation from 0 to S of the binomial distribution.
C            (Probablility of S or fewer successes in XN trials each
C            with probability of success PR.)
C            Input range: [0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: [0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C     S <--> The number of successes observed.
C            Input range: [0, XN]
C            Search range: [0, XN]
C                    DOUBLE PRECISION S
C
C     XN  <--> The number of binomial trials.
C              Input range: (0, +infinity).
C              Search range: [1E-100, 1E100]
C                    DOUBLE PRECISION XN
C
C     PR  <--> The probability of success in each binomial trial.
C              Input range: [0,1].
C              Search range: [0,1]
C                    DOUBLE PRECISION PR
C
C     OMPR  <--> 1-PR
C              Input range: [0,1].
C              Search range: [0,1]
C              PR + OMPR = 1.0
C                    DOUBLE PRECISION OMPR
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                4 if PR + OMPR .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Formula  26.5.24    of   Abramowitz  and    Stegun,  Handbook   of
C     Mathematical   Functions (1966) is   used  to reduce the  binomial
C     distribution  to  the  cumulative incomplete    beta distribution.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION zero,inf
      PARAMETER (zero=1.0D-100,inf=1.0D100)
      DOUBLE PRECISION one
      PARAMETER (one=1.0D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,ompr,p,pr,q,s,xn
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx,pq,prompr,xhi,xlo
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL cumbin,dinvr,dstinv,dstzr,dzror
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
      IF (.NOT. ((which.LT.1).AND. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
      IF (.NOT. ((q.LT.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LT.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.3) GO TO 130
      IF (.NOT. (xn.LE.0.0D0)) GO TO 120
      bound = 0.0D0
      status = -5
      RETURN

  120 CONTINUE
  130 IF (which.EQ.2) GO TO 170
      IF (.NOT. ((s.LT.0.0D0).OR. ((which.NE.3).AND.
     +    (s.GT.xn)))) GO TO 160
      IF (.NOT. (s.LT.0.0D0)) GO TO 140
      bound = 0.0D0
      GO TO 150

  140 bound = xn
  150 status = -4
      RETURN

  160 CONTINUE
  170 IF (which.EQ.4) GO TO 210
      IF (.NOT. ((pr.LT.0.0D0).OR. (pr.GT.1.0D0))) GO TO 200
      IF (.NOT. (pr.LT.0.0D0)) GO TO 180
      bound = 0.0D0
      GO TO 190

  180 bound = 1.0D0
  190 status = -6
      RETURN

  200 CONTINUE
  210 IF (which.EQ.4) GO TO 250
      IF (.NOT. ((ompr.LT.0.0D0).OR. (ompr.GT.1.0D0))) GO TO 240
      IF (.NOT. (ompr.LT.0.0D0)) GO TO 220
      bound = 0.0D0
      GO TO 230

  220 bound = 1.0D0
  230 status = -7
      RETURN

  240 CONTINUE
  250 IF (which.EQ.1) GO TO 290
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 280
      IF (.NOT. (pq.LT.0.0D0)) GO TO 260
      bound = 0.0D0
      GO TO 270

  260 bound = 1.0D0
  270 status = 3
      RETURN

  280 CONTINUE
  290 IF (which.EQ.4) GO TO 330
      prompr = pr + ompr
      IF (.NOT. (abs(((prompr)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 320
      IF (.NOT. (prompr.LT.0.0D0)) GO TO 300
      bound = 0.0D0
      GO TO 310

  300 bound = 1.0D0
  310 status = 4
      RETURN

  320 CONTINUE
  330 IF (.NOT. (which.EQ.1)) qporq = p .LE. q
      IF ((1).EQ. (which)) THEN
          CALL cumbin(s,xn,pr,ompr,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
          s = xn/2.0D0
          CALL dstinv(0.0D0,xn,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,s,fx,qleft,qhi)
  340     IF (.NOT. (status.EQ.1)) GO TO 370
          CALL cumbin(s,xn,pr,ompr,cum,ccum)
          IF (.NOT. (qporq)) GO TO 350
          fx = cum - p
          GO TO 360

  350     fx = ccum - q
  360     CALL dinvr(status,s,fx,qleft,qhi)
          GO TO 340

  370     IF (.NOT. (status.EQ.-1)) GO TO 400
          IF (.NOT. (qleft)) GO TO 380
          status = 1
          bound = 0.0D0
          GO TO 390

  380     status = 2
          bound = xn
  390     CONTINUE
  400     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          xn = 5.0D0
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,xn,fx,qleft,qhi)
  410     IF (.NOT. (status.EQ.1)) GO TO 440
          CALL cumbin(s,xn,pr,ompr,cum,ccum)
          IF (.NOT. (qporq)) GO TO 420
          fx = cum - p
          GO TO 430

  420     fx = ccum - q
  430     CALL dinvr(status,xn,fx,qleft,qhi)
          GO TO 410

  440     IF (.NOT. (status.EQ.-1)) GO TO 470
          IF (.NOT. (qleft)) GO TO 450
          status = 1
          bound = zero
          GO TO 460

  450     status = 2
          bound = inf
  460     CONTINUE
  470     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
          CALL dstzr(0.0D0,1.0D0,atol,tol)
          IF (.NOT. (qporq)) GO TO 500
          status = 0
          CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi)
          ompr = one - pr
  480     IF (.NOT. (status.EQ.1)) GO TO 490
          CALL cumbin(s,xn,pr,ompr,cum,ccum)
          fx = cum - p
          CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi)
          ompr = one - pr
          GO TO 480

  490     GO TO 530

  500     status = 0
          CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi)
          pr = one - ompr
  510     IF (.NOT. (status.EQ.1)) GO TO 520
          CALL cumbin(s,xn,pr,ompr,cum,ccum)
          fx = ccum - q
          CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi)
          pr = one - ompr
          GO TO 510

  520     CONTINUE
  530     IF (.NOT. (status.EQ.-1)) GO TO 560
          IF (.NOT. (qleft)) GO TO 540
          status = 1
          bound = 0.0D0
          GO TO 550

  540     status = 2
          bound = 1.0D0
  550     CONTINUE
  560 END IF

      RETURN

      END


program SEM1D

    !###################################################################################################################
    ! Created by mus on 28/07/2021.
    ! Spectral Elements 1D Solver with a regular mesh for the elastic wave equation
    ! NOTE: This program is yet to be tested against analytical solutions.
    !
    ! Language: Fortran 90, with parralel impelementation using OpenMP API
    !
    ! Sources:  Igel 2017
    !
    ! The code used for arbitrary GLL points and weights was created by M.I.T departement of engineering. Link is hereafter
    ! https://geodynamics.org/cig/doxygen/release/specfem3d/    | file name: gll_library.f90
    !
    ! This is part of the Numerical Modelling Workshop.
    !
    ! Supervisor: Pr. Emmanual Chaljub
    ! Author    : Mus Benziane
    !
    ! Input file: [Example]
    ! testing              ! Model name prefix (model names: prefix_vp, prefix_rho)
    ! 3                    ! Polynomial order
    ! 1000                 ! Number of elements
    ! 20                   ! Element size
    ! 5.                   ! Wavelet's peak frequency
    ! 0.001                ! Time step
    ! 10000                ! Number of time steps
    ! 1                    ! Source location (element number)
    ! 1                    ! Source location (gll point)
    ! 1                    ! [1/2/3/4] 1: Free surface, 2: Rigid wall, 3: Periodic, 4: Sponge
    ! 1                    ! Boundary condition only on the left side [not for periodic BC | on the right side for absorbing]
    ! 20                   ! Sponge layer width in gll points
    ! .65                  ! Att constant for sponge layer
    !
    ! -> Model files in C-Style binary floats [doubles]: Vs, Rho files are needed.
    !                                                  : For simple models, use create1Dmodel_files.f90
    !
    ! -> Outputs are created in OUTPUT/ if OUTPUT/ is not created by the user, the program will not handle it.
    !    Output files in OUTPUT directory:
    !
    !####################################################################################################################

    !$ USE OMP_LIB
    implicit none

    interface connectivity_matrix
        function connectivity_matrix(N,ne)
            integer, intent(in)                                :: N, ne
            integer connectivity_matrix(N+1,ne)
        end function
    end interface

    real (kind=8)                                              :: Jc, Jci, h, f0, dt, sum, CFL, mindist, lambdamin, taper
    real (kind=8)                                              :: time, t_cpu_0, t_cpu_1, t_cpu, tmp, tmpBC, attConst, sd

    real (kind=8), dimension(:), allocatable                   :: xi, wi, v1D, rho1D, Me, M, xgll, rho1Dgll, v1Dgll, g,tauL
    real (kind=8), dimension(:), allocatable                   :: mu1Dgll, u, uold, unew, F, src, temp1, temp2, temp3, Fg,&
                                                                  udot, udotnew, uddot, uddotnew, sigma, recsigma, &
                                                                  greenU, greenV
    real (kind=8), dimension(:,:), allocatable                 :: lprime, Minv, Kg, Ke,Uout, as, Udotout, sigmaout
    integer, dimension(:,:), allocatable                       :: Cij
    integer                                                    :: N, ne, ngll, i, j, k, l, nt, t, el, isnap, reclsnaps
    integer                                                    :: ir, t0, t1, esrc, gsrc, bc, sbc, gWidth, IC, ercv, grcv
    character(len=40)                                          :: filename, filecheck, outname, modnameprefix
    !$ integer                                                 :: n_workers
    logical                                                    :: OMPcheck = .false.

    write(*,*) "##########################################"
    write(*,*) "############### OpenMP     ###############"
    !$ OMPcheck = .true.
    if (OMPcheck) then
        !$OMP PARALLEL
        !$ n_workers = OMP_GET_NUM_THREADS()
        !$OMP END PARALLEL
        !$ print '(3X,"Number of workers ->  ",i2)',n_workers
    else
        write(*,*) "Program has been compiled without OpenMP; Time marching will run in serial"
    end if

    call cpu_time(t_cpu_0)
    call system_clock(count=t0, count_rate=ir)

    outname = "OUTPUT/snapshots.bin"
    filename          = "parameters.in"

    write(*,*) "##########################################"
    write(*,*) "######## Reading parameters file #########"
    write(*,*) "##########################################"

    filename="parameters.in"

    print*,"Is the parameters input file (parameters.in) [Yes/no]"
    read(*,*) filecheck

    if (filecheck=="Yes" .or. filecheck=="yes" .or. filecheck=="y" .or. &
            filecheck=="Y") then
        write(*,*) "Reading simulation parameters..."

    elseif  (filecheck=="No" .or. filecheck=="no" .or. filecheck=="n" .or. &
                filecheck=="N") then
        write(*,*) "Enter simulation parameters text file name with extension"
        write(*,*) "40 characters max"
        read(*,*) filename

    else
        write(*,*) "Only: Yes/yes/Y/y & No/no/N/n are handled"
        write(*,*) "The program have been terminated, please star over"
        stop
    end if

    open (2, file=filename, status = 'old')
    read(2,*) modnameprefix
    read(2,*) N
    read(2,*) ne
    read(2,*) h
    read(2,*) f0
    read(2,*) dt
    read(2,*) nt
    read(2,*) esrc
    read(2,*) gsrc
    read(2,*) ercv
    read(2,*) grcv
    read(2,*) isnap
    read(2,*) bc
    read(2,*) sbc
    read(2,*) gWidth
    read(2,*) attConst
    read(2,*) IC
    read(2,*) sd
    close(2)

    print*,"Polynomial order          -> ",N
    print*,"Number of elements        -> ",ne
    print*,"Element size              -> ",h
    print*,"Wavelet's peak frequency  -> ",f0
    print*,"Time step                 -> ",dt
    print*,"Number of time steps      -> ",nt
    print*,"Source location [nel/ngll]-> ",esrc, gsrc
    print*,"Snapshot interval         -> ",isnap

    ngll = N * ne + 1                  ! Total GLL points
    Jc = h / 2                         ! Jacobian for structured 1D mesh
    Jci = 1 / Jc                       ! Jacobian inverse

    allocate(Cij(N+1,ne))               ! Connectivity matrix
    allocate(xi(N+1))                   ! GLL points
    allocate(wi(N+1))                   ! GLL Quadrature weights
    allocate(v1D(ne))                   ! 1D velocity model in elements
    allocate(rho1D(ne))                 ! Density velocity model in elements
    allocate(rho1Dgll(ngll))            ! 1D density model mapped
    allocate(v1Dgll(ngll))              ! 1D velocity mapped
    allocate(M(ngll))                   ! Global mass matrix in vector form
    allocate(Minv(ngll,ngll))           ! Inverse of the mass matrix
    allocate(Me(N+1))                   ! Elemental mass matrix
    allocate(Kg(ngll,ngll))             ! Global stifness matrix
    allocate(Ke(N+1,N+1))               ! Elemental stifness matrix
    allocate(lprime(N+1,N+1))           ! Dervatives of Lagrange polynomials
    allocate(u(ngll))                   ! Displacement vector at time t
    allocate(unew(ngll),uddotnew(ngll), udotnew(ngll))                ! displacement vecotr at time t - dt
    allocate(uddot(ngll), udot(ngll), sigma(ngll))
    allocate(uold(ngll))                ! displacement vector at time t + dt
    allocate(src(nt))                   ! Source time function
    allocate(F(ngll))                   ! External force
    allocate(Fg(ngll))                  ! All forces
    allocate(temp1(ngll),temp2(ngll),temp3(ngll))
    allocate(Uout(NINT(REAL(nt/isnap)),ngll))             ! Snapshots
    allocate(Udotout(NINT(REAL(nt/isnap)),ngll),sigmaout(NINT(REAL(nt/isnap)),ngll))
    allocate(mu1Dgll(ngll))             ! Shear modulus mapped
    allocate(xgll(ngll))                ! Array for global mapping
    allocate(g(ngll))
    allocate(as(NINT(nt/REAL(isnap)),ngll))
    allocate(tauL(ngll), recsigma(nt))
    allocate(greenU(nt),greenV(nt))

    Cij  = connectivity_matrix(N,ne)

    open(28,file="DBC.bin",access="direct",recl=nt*8)
    read(28,rec=1) recsigma
    close(28)

    call lagrangeprime(N,lprime)                         ! Lagrange polynomials derivatives
    call zwgljd(xi,wi,N+1,0.,0.)                         ! Getting GLL points and weights
    call readmodelfiles1D(v1D, rho1D, ne,modnameprefix)  ! Reading model files
    call shapefunc(N,h,ne,Cij,xgll)                      ! Global domain mapping
    call mapmodel(N,ne,rho1D,v1D,rho1Dgll,v1Dgll)        ! Mapping models
    call ricker(nt,f0,dt,src)                            ! Source time function

    write(*,*)"##########################################"
    write(*,*)"############### CFL Check ################"
    write(*,*)"##########################################"

    mindist = xgll(2) - xgll(1)
    CFL = (dt/mindist) * maxval(v1D(:))

    if (CFL > .8) then
        print"(a14,f6.3)","CFL value is ",CFL
        print*,"Decrease time step, the program has been terminated"
        stop

    else
        print"(a14,f6.3)","CFL value is ",CFL
        print*,"Simulation is stable"
    end if

    write(*,*)"##########################################"
    write(*,*)"########## Space Sampling check ##########"
    write(*,*)"##########################################"
    lambdamin = minval(v1D)/(f0*2.5)

    print"(a32,f3.1)", " Elements per minimum wavelength ->", lambdamin/h

    if ((lambdamin/h)<1) then
        print*,"Element size is too large"
        print*,"Numerical dispersion might be present"
        print*,"Do you wish to continue anyways? Yes/no"
        read*, filecheck

        if (filecheck=="Yes" .or. filecheck=="yes" .or. filecheck=="y" .or. &
                filecheck=="Y") then
            print*,"Proceeding..."

        elseif  (filecheck=="No" .or. filecheck=="no" .or. filecheck=="n" .or. &
                filecheck=="N") then
            write(*,*) "The program had been terminated"
            write(*,*) "Reduce element size or frequency as such"
            write(*,*) "you have at least 1 element per min wavelength"
            write(*,*) "This holds for N=5 to N=10 as per"
            write(*,*) "Komatitsch and Tromp 1999"
            stop
        else
            write(*,*) "Only: Yes/yes/Y/y & No/no/N/n are handled"
            write(*,*) "The program have been terminated, please star over"
            stop
        end if
    else
        print*, "Spatial sampling as OK!"
    end if

    !##########################################
    !####### Construct the mass matrix ########
    !##########################################

    do i=1,ne
        do j=1,N+1
            Me(j) = rho1Dgll(Cij(j,i)) * wi(j) * Jc   ! Elemental mass matrix construction
            M(Cij(j,i)) =  M(Cij(j,i)) + Me(j)        ! Filling the global mass matrix
        end do
    end do

    if (bc .eq. 3) then ! Mass matrix edit for periodic BC
        tmp     =0.
        tmp    =M(1)
        M(1)   =M(1)+M(ngll)
        M(ngll)=M(ngll)+tmp
    end if
    Minv(:,:) = 0
    ! Invert mass matrix
    do i=1,ngll
        Minv(i,i) = 1 / M(i)
    end do

    !###############################################
    !####### Construct the Stiffness matrix ########
    !###############################################
    mu1Dgll(:) =  rho1Dgll(:) * v1Dgll(:)**2.          ! Shear modulus

    Kg(:,:) = 0
    do el=1,ne
        do i=1,N+1                                    ! Elemental stifness matrix
            do j=1,N+1
                sum = 0.
                do k=1,N+1
                    sum = sum + mu1Dgll(Cij(k,el)) * wi(k) * lprime(j,k) * lprime(i,k) * Jc * Jci**2
                end do
                Ke(i,j) = sum
            end do
        end do

        do i=1,N+1                                      ! Global assembly
            do j=1,N+1
                Kg(Cij(i,el),Cij(j,el)) = Kg(Cij(i,el),Cij(j,el)) + Ke(i,j)
            end do
        end do
    end do

    write(*,*) "###########################################"
    write(*,*) "############ BEGIN TIME LOOP ##############"
    write(*,*) "###########################################"

    uold(:)     = 0.
    u(:)        = 0.
    unew(:)     = 0.
    uddot(:)    = 0.
    uddotnew(:) = 0.
    udot(:)     = 0.
    udotnew(:)  = 0.
    F(:)        = 0.
    tauL        = 0.

    if (IC==1) then
        udot(:)    = exp(-1./sd**2*(xgll(:)-xgll(Cij(gsrc,esrc)))**2)
        uold(:) = u(:)
    end if

    k = 0;
    do t=1,nt

        !tauL(Cij(N+1,200)) = recsigma(t)

        if (IC .ne. 1) then
            F(Cij(gsrc,esrc)) =  src(t) * wi(gsrc) * Jc
        end if

        unew(:)     = u(:) + dt * udot(:) + (dt**2)/2 * uddot(:)

        temp1(:) = 0
        !$OMP PARALLEL DO PRIVATE(l) SHARED(Kg,unew,temp1,ngll) SCHEDULE(static)
        do l=1, ngll
            temp1(l) =  DOT_PRODUCT(Kg( l , : ), unew(:))
        end do
        !$OMP END PARALLEL DO

        !$OMP PARALLEL WORKSHARE
        temp2 = F(:) - temp1(:) - tauL(:)
        !$OMP END PARALLEL WORKSHARE

        if (bc .eq. 3) then ! Periodic
            Fg       = temp2
            tmp      = 0.
            tmp      = Fg(1)
            Fg(1)    = Fg(1)+Fg(ngll)
            Fg(ngll) =Fg(ngll)+tmp
            temp2    = Fg
        end if

        !$OMP PARALLEL WORKSHARE
        uddotnew(:)  = (1/M(:)) * temp2(:)
        !$OMP END PARALLEL WORKSHARE

        !$OMP PARALLEL WORKSHARE
        udotnew(:)  = udot(:) + (dt/2) * (uddot(:) + uddotnew(:))
        !$OMP END PARALLEL WORKSHARE

        do el=1,ne
            do i=1,N+1
                tmp = 0.
                do j=1,N+1
                    tmp = tmp + mu1Dgll(Cij(i,el)) * u(Cij(j,el)) * lprime(j,i) * Jci
                end do
                sigma(Cij(i,el)) = tmp
            end do
        end do
        !recsigma(t)  = sigma(Cij(N+1,200))
        !##########################################
        !##### Boundary Conditions            #####
        !##### 1: Free surface (implicit)     #####
        !##### 2: Rigid wall                  #####
        !##### 3: Periodic                    #####
        !##### 4: ABC                         #####
        !##########################################

        if (bc .eq. 2) then ! Rigid BC
            unew(1)    =   0

            if (sbc .ne. 1) then
                unew(ngll) = 0
            end if
        end if

        if (bc .eq. 4) then ! Absorbing
            tauL(ngll) = rho1Dgll(ngll)*v1Dgll(ngll)*udot(ngll)
            if (sbc .ne. 1) then
                tauL(1)    = rho1Dgll(1)*v1Dgll(1)*udot(1)
            end if
        end if

        u     = unew
        udot  = udotnew
        uddot = uddotnew

        greenU(t) = u(Cij(grcv,ercv))
        greenV(t) = udot(Cij(grcv,ercv))

        if (mod(t,isnap) == 0) then
            k = k + 1
            Uout(k,:)    = u
            Udotout(k,:) = udot
            sigmaout(k,:)= sigma

            if (mod(t,NINT(nt/10.))==0) then
                print*,"At time sample ->",t, "/",nt
            end if
        end if
    end do

    !##########################################
    !##### Analytical Solution            #####
    !##########################################
    if (IC==1) then
        k = 1

        do t=1,nt,isnap
            !$OMP WORKSHARE
            as(k,:) = 1./2.*(exp(-1./sd**2 * (xgll(:)-xgll(Cij(gsrc,esrc)) + MAXVAL(v1D)*t*dt)**2)+ &
                             exp(-1./sd**2 * (xgll(:)-xgll(Cij(gsrc,esrc)) - MAXVAL(v1D)*t*dt)**2))
            !$OMP END WORKSHARE
            k = k + 1
        end do
    end if

    write(*,*) "##########################################"
    write(*,*) "######### Write solution binary ##########"
    write(*,*) "######### Solution in OUTPUT/   ##########"
    write(*,*) "##########################################"

    outname = "OUTPUT/SEM_snapshots_U.bin"

    inquire(iolength=reclsnaps) Uout
    open(15,file=outname,access="direct",recl=reclsnaps)
    write(15,rec=1) Uout
    close(15)

    outname = "OUTPUT/SEM_snapshots_V.bin"

    open(17,file=outname,access="direct",recl=reclsnaps)
    write(17,rec=1) Udotout
    close(17)

    outname = "OUTPUT/SEM_snapshots_Sigma.bin"

    open(18,file=outname,access="direct",recl=reclsnaps)
    write(18,rec=1) sigmaout
    close(18)

    outname = "OUTPUT/SEM_Green_U.bin"

    open(19,file=outname,access="direct",recl=nt*8)
    write(19,rec=1) greenU
    close(19)

    outname = "OUTPUT/SEM_Green_V.bin"

    open(20,file=outname,access="direct",recl=nt*8)
    write(20,rec=1) greenV
    close(20)

    open(21,file="OUTPUT/source.bin",access="direct",recl=nt*8)
    write(21,rec=1) src
    close(21)

    !open(28,file="DBC.bin",access="direct",recl=nt*8)
    !write(28,rec=1) recsigma
    !close(28)

    if (IC==1) then
        reclsnaps = 0
        inquire(iolength=reclsnaps) as

        open(16,file="OUTPUT/SEM_snapshots_analytical_V.bin",access="direct",recl=reclsnaps)
        write(16,rec=1) as
        close(16)
    end if

    ! Temps elapsed final.
    call system_clock(count=t1, count_rate=ir)
    time = real(t1 - t0,kind=8) / real(ir,kind=8)

    call cpu_time(t_cpu_1)
    t_cpu = t_cpu_1 - t_cpu_0

    write(*,*) "##########################################"
    write(*,*) "######### TIME:                 ##########"
    print '(//3X,"Elapsed Time        : ",1PE10.3," [s]",/ &
            &,3X,"CPU Time            : ",1PE10.3," [s]",//)', &
            & time,t_cpu
    write(*,*) "##########################################"

    deallocate(xi,wi,v1D,v1Dgll,rho1D,rho1Dgll)
    deallocate(M,Me,Minv)
    deallocate(Cij)
    deallocate(mu1Dgll,xgll)
    deallocate(u,uold,unew,lprime,Kg,Ke)
    deallocate(Uout,Udotout,udot,udotnew,uddot,uddotnew)
    deallocate(sigma,sigmaout)
    deallocate(tauL, recsigma)
    DEALLOCATE(greenU,greenV)
    DEALLOCATE(F,Fg)

end program


SUBROUTINE lumas5(ndofn,npoin,nelem,ngaus,nnode,lnods,matno,coord, &
     &                  emass,weigp,shape,deriv,iwrit,sumat)

! calculates lumped mass for 3d 4- or 8-node element

  USE lispa0
  USE mat_dba
  IMPLICIT NONE

  INTEGER (kind=4) ndofn,nelem,ngaus,nnode,npoin,iwrit, &
 &                 lnods(:,:),matno(:)
  REAL    (kind=8) coord(3,npoin),emass(ndofn,*), &
 &                 weigp(:),shape(:,:),deriv(:,:,:),sumat

  INTEGER (kind=4) ielem,isec,kgasp,inode,lnode,osec,istop
  REAL    (kind=8) :: djacb,dvolu,shapi,sumas,sume6,tarea,rhoel

  REAL(kind=8),ALLOCATABLE :: cartd(:,:,:),elcod(:,:),diagm(:)
  TYPE (section), POINTER :: sec

  ALLOCATE (cartd(nnode,3,ngaus), elcod(3,nnode), diagm(nnode))

  osec = -1
  sume6 = 0.0
  istop = 0
  DO ielem = 1,nelem
    kgasp = 0
    tarea = 0.0
    isec = matno(ielem)
    IF( isec == 0 )CYCLE     !for rigid bodies without associated node
    IF( isec /= osec )THEN
      sec => psecs(isec)%p
      ! mscal is applied over array EMASS directly
      rhoel = sec%mtbas%prope(5) !material density, (not scaled)
      osec = isec
    END IF
    IF(rhoel == 0.0d0)CYCLE        ! massless element
    DO inode=1,nnode
      diagm(1:nnode) = 0.0
      elcod(1:3,1:nnode) = coord(1:3,lnods(1:nnode,ielem))
    END DO
    DO kgasp=1,ngaus
      CALL jacob5(cartd,deriv(1,1,kgasp),djacb,elcod,nnode,ielem,istop)
      IF(istop == 1)STOP
      dvolu = djacb*weigp(kgasp)
      IF (nnode == 8) THEN
        DO inode = 1,nnode
          shapi = shape(inode,kgasp)
          diagm(inode) = diagm(inode) + shapi*dvolu !*shapi*shapi !not good for 4 gauss points
        END DO
      ELSE IF (nnode == 4) THEN ! is valid only for ngaus = 1
        DO inode = 1,nnode
          diagm(inode) = dvolu/nnode
        END DO
      ENDIF
      tarea = tarea+dvolu
    END DO

! generates lumped mass matrix proportional to diagonal

    sumas = 0.
    DO inode=1,nnode
      sumas = sumas + diagm(inode)
    END DO
    tarea = tarea*rhoel
    sume6 = sume6+tarea
    sumas = tarea/sumas
    DO inode=1,nnode
      lnode=lnods(inode,ielem)
      emass(1:3,lnode) = emass(1:3,lnode) + diagm(inode)*sumas
    END DO
  END DO
  IF(iwrit==1) WRITE(lures,"(//' Total Mass of Element 5:',e15.7)",ERR=9999) sume6
  sumat = sumat+sume6
  DEALLOCATE (cartd, elcod, diagm)

RETURN
 9999 CALL runen2('')
END SUBROUTINE lumas5


	FUNCTION brent(ax,bx,cx,func,tol,xmin)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: ax,bx,cx,tol
	REAL(SP), INTENT(OUT) :: xmin
	REAL(SP) :: brent
	INTERFACE
		FUNCTION func(x)
		USE nrtype
		IMPLICIT NONE
		REAL(SP), INTENT(IN) :: x
		REAL(SP) :: func
		END FUNCTION func
	END INTERFACE
	INTEGER(I4B), PARAMETER :: ITMAX=100
	REAL(SP), PARAMETER :: CGOLD=0.3819660_sp,ZEPS=1.0e-3_sp*epsilon(ax)
	INTEGER(I4B) :: iter
	REAL(SP) :: a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm
	a=min(ax,cx)
	b=max(ax,cx)
	v=bx
	w=v
	x=v
	e=0.0
	fx=func(x)
	fv=fx
	fw=fx
	do iter=1,ITMAX
		xm=0.5_sp*(a+b)
		tol1=tol*abs(x)+ZEPS
		tol2=2.0_sp*tol1
		if (abs(x-xm) <= (tol2-0.5_sp*(b-a))) then
			xmin=x
			brent=fx
			RETURN
		end if
		if (abs(e) > tol1) then
			r=(x-w)*(fx-fv)
			q=(x-v)*(fx-fw)
			p=(x-v)*q-(x-w)*r
			q=2.0_sp*(q-r)
			if (q > 0.0) p=-p
			q=abs(q)
			etemp=e
			e=d
			if (abs(p) >= abs(0.5_sp*q*etemp) .or. &
				p <= q*(a-x) .or. p >= q*(b-x)) then
				e=merge(a-x,b-x, x >= xm )
				d=CGOLD*e
			else
				d=p/q
				u=x+d
				if (u-a < tol2 .or. b-u < tol2) d=sign(tol1,xm-x)
			end if
		else
			e=merge(a-x,b-x, x >= xm )
			d=CGOLD*e
		end if
		u=merge(x+d,x+sign(tol1,d), abs(d) >= tol1 )
		fu=func(u)
		if (fu <= fx) then
			if (u >= x) then
				a=x
			else
				b=x
			end if
			call shft(v,w,x,u)
			call shft(fv,fw,fx,fu)
		else
			if (u < x) then
				a=u
			else
				b=u
			end if
			if (fu <= fw .or. w == x) then
				v=w
				fv=fw
				w=u
				fw=fu
			else if (fu <= fv .or. v == x .or. v == w) then
				v=u
				fv=fu
			end if
		end if
	end do
	call nrerror('brent: exceed maximum iterations')
	CONTAINS
!BL
	SUBROUTINE shft(a,b,c,d)
	REAL(SP), INTENT(OUT) :: a
	REAL(SP), INTENT(INOUT) :: b,c
	REAL(SP), INTENT(IN) :: d
	a=b
	b=c
	c=d
	END SUBROUTINE shft
	END FUNCTION brent


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! - mod_precision - (Month - Year)
!!
!! author: Nicolas.Grima@univ-brest.fr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! This module is a necessary module to define the integer and
!! real precision.
!!
!! Remember that is it better to define explicitly the variable precision
!! in the code source than in the compiler options !!!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE mod_precision

  !================!
  !- DECLARATIONS -!
  !================!
  IMPLICIT NONE

  !===========================!
  !- INTEGER KIND DEFINITION -!
  !===========================!
  INTEGER(kind=4), PARAMETER :: &
       ishort=4               , & ! Here we decided that single precision is 4
       ilong =8                   ! and double precision is 8
  !                               ! (IEEE norm, except some cray machines)

  INTEGER(kind=ishort), PARAMETER :: &
       iprec=ishort               ! We decided that single precsion for
  !                               ! Integer variables is right.

  !========================!
  !- REAL KIND DEFINITION -!
  !========================!
  !- We use here the F90 intinsinc function KIND to determine the real precision -!
  INTEGER(kind=ishort), PARAMETER :: &
       rshort=KIND(1.0)            , & !  Real single precision
       rlong =KIND(1.0d0)              !  Real double precision

  !- Quad precision is defined here if it is required and available.
  !- Quad precision improve the stability of the results for the same
  !- compiler on different platforms (Intel versus AMD for example).
!!$#if defined quad
!!$  INTEGER(kind=ishort), PARAMETER :: qprec = selected_real_kind(p=33)
!!$#else
!!$  INTEGER(kind=ishort), PARAMETER :: qprec = rlong
!!$#endif

  !- By default compilation will be made in double-precision for real variables. -!
  INTEGER(kind=ishort), PARAMETER :: &
       rprec=rlong ! If needed, you can change rlong by rshort (not tested).

  !====================================!
  !- DECLARATIONS of INTERFACE BLOCKS -!
  !====================================!

CONTAINS

  !********************************************************************!
  !- sub_machine_precision - (Month - Year)
  !
  !- contact: Author@mail
  !********************************************************************!
  !
  !
  !
  !
  !
  !********************************************************************!

  SUBROUTINE sub_machine_precision(lun) ! lun = logical unit number (opt)

    !=============================!
    !- DECLARATIONS of ARGUMENTS -!
    !=============================!
    INTEGER(kind = iprec), OPTIONAL, INTENT(in) :: lun

    !===================================!
    !- DECLARATIONS of LOCAL VARIABLES -!
    !===================================!
    INTEGER(kind = iprec) :: local_lun = 6_iprec

    IF (PRESENT(lun)) THEN
       local_lun = lun
    ENDIF

    WRITE(local_lun,*)''
    WRITE(local_lun,*)'====================='
    WRITE(local_lun,*)'= Machine precision ='
    WRITE(local_lun,*)'====================='
    WRITE(local_lun,*)'  -            iprec:', iprec
    WRITE(local_lun,*)'  -            rprec:', rprec
!!$    WRITE(local_lun,*)'  -            qprec:', qprec
    WRITE(local_lun,*)'  -     range(iprec):', RANGE(0_iprec)
    WRITE(local_lun,*)'  -     range(rprec):', RANGE(0._rprec)
    WRITE(local_lun,*)'  - Precision(rprec):', PRECISION(1.0_rprec)
    WRITE(local_lun,*)'  -   Spacing(rprec):', SPACING(1.0_rprec)
    WRITE(local_lun,*)'  -   EPSILON(rprec):', EPSILON(1.0_rprec)

!!$    IF (qprec > 8 ) THEN
!!$       WRITE(local_lun,*)''
!!$       WRITE(local_lun,*)'-- QUADRUPLE PRECISION IS ACTIVATED --'
!!$       WRITE(local_lun,*)'        quad value = ', qprec
!!$    ENDIF

  END SUBROUTINE sub_machine_precision

END MODULE mod_precision
!!***


program problem_1

!! Find the two entries that sum to 2020;
!! what do you get if you multiply them together?

use aoc_utilities, only: read_file_to_integer_array

implicit none

integer,dimension(:),allocatable :: iarray
integer :: i, j

iarray = read_file_to_integer_array('input.txt')

do i = 1, size(iarray)
    do j = i+1, size(iarray)
        if (iarray(i) + iarray(j) == 2020) then
            write(*,*) iarray(i) , '*', iarray(j), iarray(i) * iarray(j)
            stop
        end if
    end do
end do

end program problem_1


MODULE Solve_Complex_Poly
!     ALGORITHM 419 COLLECTED ALGORITHMS FROM ACM.

! Code converted using TO_F90 by Alan Miller
! Date: 2000-01-08  Time: 16:02:44

! Latest revision - 10 February 2000
! amiller @ bigpond.net.au

!     ALGORITHM APPEARED IN COMM. ACM, VOL. 15, NO. 02, P. 097.

USE quadruple_precision
IMPLICIT NONE

! COMMON AREA
! COMMON /global/ pr, pi, hr, hi, qpr, qpi, qhr, qhi, shr, shi, sr,  &
!    si, tr, ti, pvr, pvi, are, mre, eta, infin, nn
! TYPE (quad) :: sr, si, tr, ti, pvr, pvi, are, mre, eta, infin,  &
!    pr(50), pi(50), hr(50), hi(50), qpr(50), qpi(50), qhr(50),  &
!    qhi(50), shr(50), shi(50)

! N.B. pi has been changed to ci as the constant pi = 3.14159...
!      is available from the quad.precision module.

TYPE (quad), ALLOCATABLE, SAVE  :: pr(:), ci(:), hr(:), hi(:), qpr(:), qpi(:), &
                                   qhr(:), qhi(:), shr(:), shi(:)
TYPE (quad), SAVE               :: sr, si, tr, ti, pvr, pvi, are, mre, eta,  &
                                   infin
INTEGER, SAVE                   :: nn

PRIVATE
PUBLIC  :: cpoly

CONTAINS

SUBROUTINE cpoly(opr, opi, degree, zeror, zeroi, fail)
! FINDS THE ZEROS OF A COMPLEX POLYNOMIAL.
! OPR, OPI  -  TYPE (quad) VECTORS OF REAL AND IMAGINARY PARTS OF THE
!              COEFFICIENTS IN ORDER OF DECREASING POWERS.
! DEGREE    -  INTEGER DEGREE OF POLYNOMIAL.
! ZEROR, ZEROI  -  OUTPUT TYPE (quad) VECTORS OF REAL AND IMAGINARY
!                  PARTS OF THE ZEROS.
! FAIL      -  OUTPUT LOGICAL PARAMETER,  TRUE ONLY IF LEADING COEFFICIENT
!              IS ZERO OR IF CPOLY HAS FOUND FEWER THAN DEGREE ZEROS.
! THE PROGRAM HAS BEEN WRITTEN TO REDUCE THE CHANCE OF OVERFLOW OCCURRING.
! IF IT DOES OCCUR, THERE IS STILL A POSSIBILITY THAT THE ZEROFINDER WILL WORK
! PROVIDED THE OVERFLOWED QUANTITY IS REPLACED BY A LARGE NUMBER.

TYPE (quad), INTENT(IN)   :: opr(:)
TYPE (quad), INTENT(IN)   :: opi(:)
INTEGER, INTENT(IN)       :: degree
TYPE (quad), INTENT(OUT)  :: zeror(:)
TYPE (quad), INTENT(OUT)  :: zeroi(:)
LOGICAL, INTENT(OUT)      :: fail

TYPE (quad) :: xx, yy, cosr, sinr, smalno, base, xxx, zr, zi, bnd
LOGICAL     :: conv
INTEGER     :: cnt1, cnt2, i, idnn2

! INITIALIZATION OF CONSTANTS
CALL mcon(eta, infin, smalno, base)
are = eta
mre = 2.0_dp * SQRT(2.0_dp) * eta
xx = .70710678
yy = -xx
cosr = -.060756474
sinr = .99756405
fail = .false.
nn = degree + 1

! ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO.
IF (opr(1)%hi == 0.0_dp .AND. opi(1)%hi == 0.0_dp) THEN
  fail = .true.
  RETURN
END IF

! Allocate arrays

IF (ALLOCATED(pr)) DEALLOCATE(pr, ci, hr, hi, qpr, qpi, qhr, qhi, shr, shi)
ALLOCATE(pr(nn), ci(nn), hr(nn), hi(nn), qpr(nn), qpi(nn), qhr(nn),  &
         qhi(nn), shr(nn), shi(nn))

! REMOVE THE ZEROS AT THE ORIGIN IF ANY.
10 IF (opr(nn)%hi == 0.0_dp .AND. opi(nn)%hi == 0.0_dp) THEN
  idnn2 = degree - nn + 2
  zeror(idnn2) = 0.0_dp
  zeroi(idnn2) = 0.0_dp
  nn = nn - 1
  GO TO 10
END IF

! MAKE A COPY OF THE COEFFICIENTS.
DO  i = 1, nn
  pr(i) = opr(i)
  ci(i) = opi(i)
  shr(i) = cmod(pr(i), ci(i))
END DO

! SCALE THE POLYNOMIAL.
bnd = scalepoly(nn, shr, eta, infin, smalno, base)
IF (bnd%hi /= 1.0_dp) THEN
  DO  i = 1, nn
    pr(i) = bnd * pr(i)
    ci(i) = bnd * ci(i)
  END DO
END IF

! START THE ALGORITHM FOR ONE ZERO .
40 IF (nn <= 2) THEN

! CALCULATE THE FINAL ZERO AND RETURN.
  CALL cdivid(-pr(2), -ci(2), pr(1), ci(1), zeror(degree), zeroi(degree))
  RETURN
END IF

! CALCULATE BND, A LOWER BOUND ON THE MODULUS OF THE ZEROS.
DO  i = 1, nn
  shr(i) = cmod(pr(i), ci(i))
END DO
CALL cauchy(nn, shr, shi, bnd)

! OUTER LOOP TO CONTROL 2 MAJOR PASSES WITH DIFFERENT SEQUENCES OF SHIFTS.
DO  cnt1 = 1, 2

! FIRST STAGE CALCULATION, NO SHIFT.
  CALL noshft(5)

! INNER LOOP TO SELECT A SHIFT.
  DO  cnt2 = 1, 9

! SHIFT IS CHOSEN WITH MODULUS BND AND AMPLITUDE ROTATED BY
! 94 DEGREES FROM THE PREVIOUS SHIFT
    xxx = cosr * xx - sinr * yy
    yy = sinr * xx + cosr * yy
    xx = xxx
    sr = bnd * xx
    si = bnd * yy

! SECOND STAGE CALCULATION, FIXED SHIFT.
    CALL fxshft(10*cnt2,zr,zi,conv)
    IF (conv) THEN

! THE SECOND STAGE JUMPS DIRECTLY TO THE THIRD STAGE ITERATION.
! IF SUCCESSFUL THE ZERO IS STORED AND THE POLYNOMIAL DEFLATED.
      idnn2 = degree - nn + 2
      zeror(idnn2) = zr
      zeroi(idnn2) = zi
      nn = nn - 1
      DO  i = 1, nn
        pr(i) = qpr(i)
        ci(i) = qpi(i)
      END DO
      GO TO 40
    END IF

! IF THE ITERATION IS UNSUCCESSFUL ANOTHER SHIFT IS CHOSEN.
  END DO

! IF 9 SHIFTS FAIL, THE OUTER LOOP IS REPEATED WITH ANOTHER SEQUENCE OF SHIFTS.
END DO

! THE ZEROFINDER HAS FAILED ON TWO MAJOR PASSES.
! RETURN EMPTY HANDED.
fail = .true.
RETURN
END SUBROUTINE cpoly

SUBROUTINE noshft(l1)
! COMPUTES  THE DERIVATIVE  POLYNOMIAL AS THE INITIAL H
! POLYNOMIAL AND COMPUTES L1 NO-SHIFT H POLYNOMIALS.

INTEGER, INTENT(IN)  :: l1

TYPE (quad) :: xni, t1, t2
INTEGER     :: i, j, jj, n, nm1

n = nn - 1
nm1 = n - 1
DO  i = 1, n
  xni = nn - i
  hr(i) = xni * pr(i) / n
  hi(i) = xni * ci(i) / n
END DO
DO  jj = 1, l1
  IF (cmod(hr(n), hi(n)) > eta*10.0_dp*cmod(pr(n), ci(n))) THEN
    CALL cdivid(-pr(nn), -ci(nn), hr(n), hi(n), tr, ti)
    DO  i = 1, nm1
      j = nn - i
      t1 = hr(j-1)
      t2 = hi(j-1)
      hr(j) = tr * t1 - ti * t2 + pr(j)
      hi(j) = tr * t2 + ti * t1 + ci(j)
    END DO
    hr(1) = pr(1)
    hi(1) = ci(1)
  ELSE

! IF THE CONSTANT TERM IS ESSENTIALLY ZERO, SHIFT H COEFFICIENTS.
    DO  i = 1, nm1
      j = nn - i
      hr(j) = hr(j-1)
      hi(j) = hi(j-1)
    END DO
    hr(1) = 0.0_dp
    hi(1) = 0.0_dp
  END IF
END DO
RETURN
END SUBROUTINE noshft

SUBROUTINE fxshft(l2, zr, zi, conv)
! COMPUTES L2 FIXED-SHIFT H POLYNOMIALS AND TESTS FOR CONVERGENCE.
! INITIATES A VARIABLE-SHIFT ITERATION AND RETURNS WITH THE
! APPROXIMATE ZERO IF SUCCESSFUL.
! L2 - LIMIT OF FIXED SHIFT STEPS
! ZR,ZI - APPROXIMATE ZERO IF CONV IS .TRUE.
! CONV  - LOGICAL INDICATING CONVERGENCE OF STAGE 3 ITERATION

INTEGER, INTENT(IN)       :: l2
TYPE (quad), INTENT(OUT)  :: zr
TYPE (quad), INTENT(OUT)  :: zi
LOGICAL, INTENT(OUT)      :: conv

TYPE (quad) :: otr, oti, svsr, svsi
LOGICAL     :: test, pasd, bool
INTEGER     :: i, j, n

n = nn - 1

! EVALUATE P AT S.
CALL polyev(nn, sr, si, pr, ci, qpr, qpi, pvr, pvi)
test = .true.
pasd = .false.

! CALCULATE FIRST T = -P(S)/H(S).
CALL calct(bool)

! MAIN LOOP FOR ONE SECOND STAGE STEP.
DO  j = 1, l2
  otr = tr
  oti = ti

! COMPUTE NEXT H POLYNOMIAL AND NEW T.
  CALL nexth(bool)
  CALL calct(bool)
  zr = sr + tr
  zi = si + ti

! TEST FOR CONVERGENCE UNLESS STAGE 3 HAS FAILED ONCE OR THIS
! IS THE LAST H POLYNOMIAL.
  IF (.NOT.(bool.OR..NOT.test.OR.j == l2)) THEN
    IF (cmod(tr-otr,ti-oti) < .5_dp*cmod(zr,zi)) THEN
      IF (pasd) THEN

! THE WEAK CONVERGENCE TEST HAS BEEN PASSED TWICE, START THE THIRD STAGE
! ITERATION, AFTER SAVING THE CURRENT H POLYNOMIAL AND SHIFT.
        DO  i = 1, n
          shr(i) = hr(i)
          shi(i) = hi(i)
        END DO
        svsr = sr
        svsi = si
        CALL vrshft(10,zr,zi,conv)
        IF (conv) RETURN

! THE ITERATION FAILED TO CONVERGE. TURN OFF TESTING AND RESTORE H,S,PV AND T.
        test = .false.
        DO  i = 1, n
          hr(i) = shr(i)
          hi(i) = shi(i)
        END DO
        sr = svsr
        si = svsi
        CALL polyev(nn, sr, si, pr, ci, qpr, qpi, pvr, pvi)
        CALL calct(bool)
        CYCLE
      END IF
      pasd = .true.
    ELSE
      pasd = .false.
    END IF
  END IF
END DO

! ATTEMPT AN ITERATION WITH FINAL H POLYNOMIAL FROM SECOND STAGE.
CALL vrshft(10, zr, zi, conv)
RETURN
END SUBROUTINE fxshft

SUBROUTINE vrshft(l3, zr, zi, conv)
! CARRIES OUT THE THIRD STAGE ITERATION.
! L3 - LIMIT OF STEPS IN STAGE 3.
! ZR,ZI   - ON ENTRY CONTAINS THE INITIAL ITERATE, IF THE
!           ITERATION CONVERGES IT CONTAINS THE FINAL ITERATE ON EXIT.
! CONV    -  .TRUE. IF ITERATION CONVERGES

INTEGER, INTENT(IN)          :: l3
TYPE (quad), INTENT(IN OUT)  :: zr
TYPE (quad), INTENT(IN OUT)  :: zi
LOGICAL, INTENT(OUT)         :: conv

TYPE (quad) :: mp, ms, omp, relstp, r1, r2, tp
LOGICAL     :: b, bool
INTEGER     :: i, j

conv = .false.
b = .false.
sr = zr
si = zi

! MAIN LOOP FOR STAGE THREE
DO  i = 1, l3

! EVALUATE P AT S AND TEST FOR CONVERGENCE.
  CALL polyev(nn, sr, si, pr, ci, qpr, qpi, pvr, pvi)
  mp = cmod(pvr, pvi)
  ms = cmod(sr,si)
  IF (mp <= 20.0_dp*errev(nn, qpr, qpi, ms, mp, are, mre)) THEN

! POLYNOMIAL VALUE IS SMALLER IN VALUE THAN A BOUND ON THE ERROR
! IN EVALUATING P, TERMINATE THE ITERATION.
    conv = .true.
    zr = sr
    zi = si
    RETURN
  END IF
  IF (i /= 1) THEN
    IF (.NOT.(b .OR. mp < omp .OR. relstp >= quad(.05_dp,0.0_dp))) THEN

! ITERATION HAS STALLED. PROBABLY A CLUSTER OF ZEROS.  DO 5 FIXED
! SHIFT STEPS INTO THE CLUSTER TO FORCE ONE ZERO TO DOMINATE.
      tp = relstp
      b = .true.
      IF (relstp < eta) tp = eta
      r1 = SQRT(tp)
      r2 = sr * (1.0_dp+r1) - si * r1
      si = sr * r1 + si * (1.0_dp+r1)
      sr = r2
      CALL polyev(nn, sr, si, pr, ci, qpr, qpi, pvr, pvi)
      DO  j = 1, 5
        CALL calct(bool)
        CALL nexth(bool)
      END DO
      omp = infin
      GO TO 20
    END IF

! EXIT IF POLYNOMIAL VALUE INCREASES SIGNIFICANTLY.
    IF (mp*.1_dp > omp) RETURN
  END IF
  omp = mp

! CALCULATE NEXT ITERATE.
  20 CALL calct(bool)
  CALL nexth(bool)
  CALL calct(bool)
  IF (.NOT.bool) THEN
    relstp = cmod(tr,ti) / cmod(sr,si)
    sr = sr + tr
    si = si + ti
  END IF
END DO
RETURN
END SUBROUTINE vrshft

SUBROUTINE calct(bool)
! COMPUTES  T = -P(S)/H(S).
! BOOL   - LOGICAL, SET TRUE IF H(S) IS ESSENTIALLY ZERO.

LOGICAL, INTENT(OUT)  :: bool

TYPE (quad) :: hvr, hvi
INTEGER     :: n

n = nn - 1

! EVALUATE H(S).
CALL polyev(n, sr, si, hr, hi, qhr, qhi, hvr, hvi)
bool = cmod(hvr,hvi) <= are * 10.0_dp * cmod(hr(n), hi(n))
IF (.NOT.bool) THEN
  CALL cdivid(-pvr, -pvi, hvr, hvi, tr, ti)
  RETURN
END IF
tr = 0.0_dp
ti = 0.0_dp
RETURN
END SUBROUTINE calct

SUBROUTINE nexth(bool)
! CALCULATES THE NEXT SHIFTED H POLYNOMIAL.
! BOOL   -  LOGICAL, IF .TRUE. H(S) IS ESSENTIALLY ZERO

LOGICAL, INTENT(IN)  :: bool

TYPE (quad) :: t1, t2
INTEGER     :: j, n

n = nn - 1
IF (.NOT.bool) THEN
  DO  j = 2, n
    t1 = qhr(j-1)
    t2 = qhi(j-1)
    hr(j) = tr * t1 - ti * t2 + qpr(j)
    hi(j) = tr * t2 + ti * t1 + qpi(j)
  END DO
  hr(1) = qpr(1)
  hi(1) = qpi(1)
  RETURN
END IF

! IF H(S) IS ZERO REPLACE H WITH QH.
DO  j = 2, n
  hr(j) = qhr(j-1)
  hi(j) = qhi(j-1)
END DO
hr(1) = 0.0_dp
hi(1) = 0.0_dp
RETURN
END SUBROUTINE nexth

SUBROUTINE polyev(nn, sr, si, pr, ci, qr, qi, pvr, pvi)
! EVALUATES A POLYNOMIAL  P  AT  S  BY THE HORNER RECURRENCE
! PLACING THE PARTIAL SUMS IN Q AND THE COMPUTED VALUE IN PV.

INTEGER, INTENT(IN)       :: nn
TYPE (quad), INTENT(IN)   :: sr
TYPE (quad), INTENT(IN)   :: si
TYPE (quad), INTENT(IN)   :: pr(:)
TYPE (quad), INTENT(IN)   :: ci(:)
TYPE (quad), INTENT(OUT)  :: qr(:)
TYPE (quad), INTENT(OUT)  :: qi(:)
TYPE (quad), INTENT(OUT)  :: pvr
TYPE (quad), INTENT(OUT)  :: pvi

TYPE (quad) :: t
INTEGER     :: i

qr(1) = pr(1)
qi(1) = ci(1)
pvr = qr(1)
pvi = qi(1)
DO  i = 2, nn
  t = pvr * sr - pvi * si + pr(i)
  pvi = pvr * si + pvi * sr + ci(i)
  pvr = t
  qr(i) = pvr
  qi(i) = pvi
END DO
RETURN
END SUBROUTINE polyev

FUNCTION errev(nn, qr, qi, ms, mp, are, mre) RESULT(fn_val)
! BOUNDS THE ERROR IN EVALUATING THE POLYNOMIAL BY THE HORNER RECURRENCE.
! QR,QI - THE PARTIAL SUMS
! MS    -MODULUS OF THE POINT
! MP    -MODULUS OF POLYNOMIAL VALUE
! ARE, MRE -ERROR BOUNDS ON COMPLEX ADDITION AND MULTIPLICATION

INTEGER, INTENT(IN)      :: nn
TYPE (quad), INTENT(IN)  :: qr(:)
TYPE (quad), INTENT(IN)  :: qi(:)
TYPE (quad), INTENT(IN)  :: ms
TYPE (quad), INTENT(IN)  :: mp
TYPE (quad), INTENT(IN)  :: are
TYPE (quad), INTENT(IN)  :: mre
TYPE (quad)              :: fn_val

TYPE (quad) :: e
INTEGER     :: i

e = cmod(qr(1), qi(1)) * mre / (are+mre)
DO  i = 1, nn
  e = e * ms + cmod(qr(i), qi(i))
END DO
fn_val = e * (are+mre) - mp * mre
RETURN
END FUNCTION errev

SUBROUTINE cauchy(nn, pt, q, fn_val)
! CAUCHY COMPUTES A LOWER BOUND ON THE MODULI OF THE ZEROS OF A
! POLYNOMIAL - PT IS THE MODULUS OF THE COEFFICIENTS.

INTEGER, INTENT(IN)       :: nn
TYPE (quad), INTENT(OUT)  :: pt(:), q(:), fn_val

TYPE (quad) :: x, xm, f, dx, df
INTEGER     :: i, n

pt(nn) = -pt(nn)

! COMPUTE UPPER ESTIMATE OF BOUND.
n = nn - 1
x = EXP((LOG(-pt(nn)) - LOG(pt(1))) / n)
IF (pt(n)%hi /= 0.0_dp) THEN

! IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT.
  xm = -pt(nn) / pt(n)
  IF (xm < x) x = xm
END IF

! CHOP THE INTERVAL (0,X) UNITL F LE 0.
10 xm = x * .1_dp
f = pt(1)
DO  i = 2, nn
  f = f * xm + pt(i)
END DO
IF (f%hi > 0.0_dp) THEN
  x = xm
  GO TO 10
END IF
dx = x

! DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES.
30 IF (ABS(dx/x) > quad(.005_dp,0.0_dp)) THEN
  q(1) = pt(1)
  DO  i = 2, nn
    q(i) = q(i-1) * x + pt(i)
  END DO
  f = q(nn)
  df = q(1)
  DO  i = 2, n
    df = df * x + q(i)
  END DO
  dx = f / df
  x = x - dx
  GO TO 30
END IF
fn_val = x

RETURN
END SUBROUTINE cauchy

FUNCTION scalepoly(nn, pt, eta, infin, smalno, base) RESULT(fn_val)
! RETURNS A SCALE FACTOR TO MULTIPLY THE COEFFICIENTS OF THE POLYNOMIAL.
! THE SCALING IS DONE TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW
! INTERFERING WITH THE CONVERGENCE CRITERION.  THE FACTOR IS A POWER OF THE
! BASE.
! PT - MODULUS OF COEFFICIENTS OF P
! ETA, INFIN, SMALNO, BASE - CONSTANTS DESCRIBING THE FLOATING POINT ARITHMETIC.

INTEGER, INTENT(IN)      :: nn
TYPE (quad), INTENT(IN)  :: pt(:)
TYPE (quad), INTENT(IN)  :: eta
TYPE (quad), INTENT(IN)  :: infin
TYPE (quad), INTENT(IN)  :: smalno
TYPE (quad), INTENT(IN)  :: base
TYPE (quad)              :: fn_val

TYPE (quad) :: high, low, MAX, MIN, x, sc
INTEGER     :: i, l

! FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
high = SQRT(infin)
low = smalno / eta
MAX = 0.0_dp
MIN = infin
DO  i = 1, nn
  x = pt(i)
  IF (x > MAX) MAX = x
  IF (x%hi /= 0.0_dp .AND. x < MIN) MIN = x
END DO

! SCALE ONLY IF THERE ARE VERY LARGE OR VERY SMALL COMPONENTS.
fn_val = 1.0_dp
IF (MIN >= low .AND. MAX <= high) RETURN
x = low / MIN
IF (x%hi <= 1.0_dp) THEN
  sc = 1.0_dp / (SQRT(MAX)*SQRT(MIN))
ELSE
  sc = x
  IF (infin/sc > MAX) sc = 1.0_dp
END IF
l = LOG(sc) / LOG(base) + .5
fn_val = base ** l

RETURN
END FUNCTION scalepoly

SUBROUTINE cdivid(ar, ai, br, bi, cr, ci)
! COMPLEX DIVISION C = A/B, AVOIDING OVERFLOW.

TYPE (quad), INTENT(IN)   :: ar
TYPE (quad), INTENT(IN)   :: ai
TYPE (quad), INTENT(IN)   :: br
TYPE (quad), INTENT(IN)   :: bi
TYPE (quad), INTENT(OUT)  :: cr
TYPE (quad), INTENT(OUT)  :: ci

TYPE (quad) :: r, d, t, infin

IF (br%hi == 0.0_dp .AND. bi%hi == 0.0_dp) THEN

! DIVISION BY ZERO, C = INFINITY.
  CALL mcon(t, infin, t, t)
  cr = infin
  ci = infin
  RETURN
END IF
IF (ABS(br) < ABS(bi)) THEN
  r = br / bi
  d = bi + r * br
  cr = (ar*r+ai) / d
  ci = (ai*r-ar) / d
  RETURN
END IF
r = bi / br
d = br + r * bi
cr = (ar+ai*r) / d
ci = (ai-ar*r) / d
RETURN
END SUBROUTINE cdivid

FUNCTION cmod(r, i) RESULT(fn_val)
! MODULUS OF A COMPLEX NUMBER AVOIDING OVERFLOW.

TYPE (quad), INTENT(IN)  :: r
TYPE (quad), INTENT(IN)  :: i
TYPE (quad)              :: fn_val

TYPE (quad) :: ar, ai

ar = ABS(r)
ai = ABS(i)
IF (ar < ai) THEN
  fn_val = ai * SQRT(1.0_dp + (ar/ai)**2)
  RETURN
END IF
IF (ar > ai) THEN
  fn_val = ar * SQRT(1.0_dp + (ai/ar)**2)
  RETURN
END IF
fn_val = ar * SQRT(2.0_dp)
RETURN
END FUNCTION cmod

SUBROUTINE mcon(eta, infiny, smalno, base)
! MCON PROVIDES MACHINE CONSTANTS USED IN VARIOUS PARTS OF THE PROGRAM.
! THE USER MAY EITHER SET THEM DIRECTLY OR USE THE STATEMENTS BELOW TO
! COMPUTE THEM. THE MEANING OF THE FOUR CONSTANTS ARE -
! ETA       THE MAXIMUM RELATIVE REPRESENTATION ERROR WHICH CAN BE DESCRIBED
!           AS THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
!           1.0_dp + ETA > 1.0.
! INFINY    THE LARGEST FLOATING-POINT NUMBER
! SMALNO    THE SMALLEST POSITIVE FLOATING-POINT NUMBER
! BASE      THE BASE OF THE FLOATING-POINT NUMBER SYSTEM USED

TYPE (quad), INTENT(OUT)  :: eta, infiny, smalno, base

base   = RADIX(0.0_dp)
eta    = EPSILON(0.0_dp) * 1.0E-15_dp
infiny = HUGE(0.0_dp)
smalno = TINY(0.0_dp)

RETURN
END SUBROUTINE mcon

END MODULE Solve_Complex_Poly

PROGRAM cpolydr
!              DRIVER TO TEST CPOLY

USE quadruple_precision
USE Solve_Complex_Poly
IMPLICIT NONE

LOGICAL     :: fail
TYPE (quad) :: p(50), ci(50), zr(50), zi(50)
INTEGER     :: i

WRITE (6,5000)
p(1) = 1
p(2) = -55
p(3) = 1320
p(4) = -18150
p(5) = 157773
p(6) = -902055
p(7) = 3416930
p(8) = -8409500
p(9) = 12753576
p(10) = -10628640
p(11) = 3628800
ci(1:11) = quad(0.0_dp,0.0_dp)
CALL prtc(11, p, ci)
CALL cpoly(p, ci, 10, zr, zi, fail)
IF (fail) GO TO 60
CALL prtz(10, zr, zi)

20 WRITE (6,5100)
p(1) = 1
p(2) = 0
p(3) = -10001.0001_dp
p(4) = 0
ci(1) = 0
ci(2) = -10001.0001_dp
ci(3) = 0
ci(4) = 1
CALL prtc(4, p, ci)
CALL cpoly(p, ci, 3, zr, zi, fail)
IF (fail) GO TO 70
CALL prtz(3,zr,zi)

30 WRITE (6,5200)
p(1) = 1.0
p(2) = -1.998046875
p(3) = 0.0
p(4) = .7567065954208374_dp
p(5) = -.2002119533717632_dp
p(6) = 1.271507365163416D-2
p(7) = 0
p(8) = -1.154642632172909D-5
p(9) = 1.584803612786345D-7
p(10) = -4.652065399568528D-10
p(11) = 0
ci(1) = 0
ci(2) = p(2)
ci(3) = 2.658859252929688_dp
ci(4) = -7.567065954208374D-1
ci(5) = 0
ci(6) = p(6)
ci(7) = -7.820779428584501D-4
ci(8) = -p(8)
ci(9) = 0
ci(10) = p(10)
ci(11) = 9.094947017729282D-13
CALL prtc(11, p, ci)
CALL cpoly(p, ci, 10, zr, zi, fail)
IF (fail) GO TO 80
CALL prtz(10, zr, zi)

40 WRITE (6,5300)
p(1) = 1
p(2) = -10
p(3) = 3
p(4) = 284
p(5) = -1293
p(6) = 2374
p(7) = -1587
p(8) = -920
p(9) = 2204
p(10) = -1344
p(11) = 288
ci(1) = 0
ci(2) = -10
ci(3) = 100
ci(4) = -334
ci(5) = 200
ci(6) = 1394
ci(7) = -3836
ci(8) = 4334
ci(9) = -2352
ci(10) = 504
ci(11) = 0
CALL prtc(11, p, ci)
CALL cpoly(p, ci, 10, zr, zi, fail)
IF (fail) GO TO 90
CALL prtz(10, zr, zi)

50 WRITE (6,5400)
p(1) = 1
p(2) = 0
p(3) = -264
p(4) = 0
p(5) = 7920
p(6) = 0
p(7) = -59136
p(8) = 0
p(9) = 126720
p(10) = 0
p(11) = -67584
p(12) = 0
p(13) = 4095
ci(1) = 0
ci(2) = -24
ci(3) = 0
ci(4) = 1760
ci(5) = 0
ci(6) = -25344
ci(7) = 0
ci(8) = 101376
ci(9) = 0
ci(10) = -112640
ci(11) = 0
ci(12) = 24576
ci(13) = 0
CALL prtc(13, p, ci)
CALL cpoly(p, ci, 12, zr, zi, fail)
IF (fail) GO TO 100
CALL prtz(12, zr, zi)
STOP

60 WRITE (6,5500)
GO TO 20
70 WRITE (6,5500)
GO TO 30
80 WRITE (6,5500)
GO TO 40
90 WRITE (6,5500)
GO TO 50
100 WRITE (6,5500)
STOP

5000 FORMAT ('1EXAMPLE 1. POLYNOMIAL WITH ZEROS 1,2,...,10.')
5100 FORMAT ('1EXAMPLE 2. ZEROS ON IMAGINARY AXIS DEGREE 3.')
5200 FORMAT ('1EXAMPLE 3. ZEROS AT 1+I,1/2*(1+I)....1/(2**-9)*(1+I)')
5300 FORMAT ('1EXAMPLE 4. MULTIPLE ZEROS')
5400 FORMAT ('1EXAMPLE 5. 12 ZEROS EVENLY DISTRIBUTED ON A CIRCLE OF',  &
             ' RADIUS 1. CENTERED AT 0+2I.')
5500 FORMAT (//' CPOLY HAS FAILED ON THIS EXAMPLE')

CONTAINS

SUBROUTINE prtc(n, p, q)

INTEGER, INTENT(IN)      :: n
TYPE (quad), INTENT(IN)  :: p(50)
TYPE (quad), INTENT(IN)  :: q(50)

WRITE (6,5000) (p(i)%hi,q(i)%hi,i = 1,n)
RETURN
5000 FORMAT (//' COEFFICIENTS'/ 50(2G26.16/))
END SUBROUTINE prtc

SUBROUTINE prtz(n, zr, zi)

INTEGER, INTENT(IN)      :: n
TYPE (quad), INTENT(IN)  :: zr(50)
TYPE (quad), INTENT(IN)  :: zi(50)

WRITE (6,5000) (zr(i)%hi,zi(i)%hi,i = 1,n)
RETURN
5000 FORMAT (//' ZEROS'/50(2G26.16/))
END SUBROUTINE prtz

END PROGRAM cpolydr


	SUBROUTINE PS_USTB  ( datain, nparm, plev, outdat, iret )
C************************************************************************
C* PS_USTB								*
C*									*
C* This subroutine finds the most unstable level of a sounding from	*
C* surface up to PLEV. The most unstable level is defined as the level	*
C* which has the warmest pseudo	wet-bulb potential temperature computed	*
C* by lifting the air parcel to saturation then returning it moist	*
C* adiabatically to 1000 mb.  If plev = -1, the entire sounding	is	*
C* searched.								*
C*									*
C* PS_USTB  ( DATAIN, NPARM, PLEV, OUTDAT, IRET )			*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Input sounding data		*
C*	NPARM		INTEGER         Number of parameters		*
C*	PLEV		REAL		Pressure level			*
C*									*
C* Output parameters:							*
C*	OUTDAT (*)	REAL		Data at the most unstable level	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* T. Lee/GSC		 1/00	Created					*
C* T. Lee/GSC		 4/01	Assigned plev to a temporary variable	*
C* T. Piper/SAIC	 4/02	Fixed UMR; initialized datout		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	PARAMETER	( NPMS = 10 )
C*
	REAL            datain (*), outdat (*)
C*
	REAL		datlev (NPMS), datout (NPMS)
	LOGICAL		done
C*
C------------------------------------------------------------------------
	iret = 0
	eps  = RMISSD
	ppp  = plev
C
C*	Find the top and surface level.
C
	CALL PC_FTOP ( datain, nparm, nlev, datlev, ier )
	ptop = datlev ( 1 )
	CALL PC_FLVL ( 0., 1, datain, psfc, level1, level2, lvtyp, ier )
C
	IF  ( ppp .gt. psfc )  THEN
	    DO  i = 1, NPMS
		outdat ( i ) = RMISSD
	    END DO
	    RETURN
	  ELSE IF ( ( ppp .eq. -1. ) .or. ( ppp .le. ptop ) ) THEN
	    ppp = ptop
	END IF
C
C*	Loop through the sounding data.
C
	done  = .false.
	lev   = 1
	DO i = 1, NPMS
	    datout (i) = RMISSD
	END DO

	DO WHILE  ( .not. done )
	    CALL PC_GLEV    ( lev, datain, nparm, datlev, ier )
	    CALL PC_COMP    ( 5, datlev, datout, ier )
	    pres  = datout  ( 1 )
	    tmpc  = datout  ( 2 )
	    dwpc  = datout  ( 3 )
	    thwc  = PR_THWC ( pres, tmpc, dwpc )
C
	    IF  ( ( thwc .gt. eps ) .and. ( pres .ge. ppp ) )  THEN
		eps = thwc
		DO  i = 1, NPMS
		    outdat ( i ) = datout ( i )
		END DO
	    END IF
	    lev = lev + 1
	    IF  ( pres .le. ppp )  done = .true.
	END DO
C*
	RETURN
	END


!===================================================================================
!=================== SUBROUTINE ADAMS BASHFORTH ====================================
!=================== DENSITY & VELOCITY  ===========================================

subroutine ab2coh(Nx,Ny,Nh,pi,time,nk,ukx,uky,nk_new,ukx_new,uky_new, &
dn_dt_old,dux_dt_old,duy_dt_old,dn_dt_new,dux_dt_new,duy_dt_new)
implicit none
integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) pi,time,dt,Lx,Ly,mux,muy,ms,CS
complex ( kind = 8 ) nk(Nh,Ny),ukx(Nh,Ny),uky(Nh,Ny),nk_new(Nh,Ny),ukx_new(Nh,Ny),uky_new(Nh,Ny)
complex ( kind = 8 ) dn_dt_old(Nh,Ny),dux_dt_old(Nh,Ny),duy_dt_old(Nh,Ny)
complex ( kind = 8 ) dn_dt_new(Nh,Ny),dux_dt_new(Nh,Ny),duy_dt_new(Nh,Ny)
common/comm/Lx,Ly,mux,muy,ms,CS,dt

!$OMP PARALLEL SHARED(dt,nk,ukx,uky,nk_new,ukx_new,uky_new,dn_dt_new,dux_dt_new,duy_dt_new),&
!$OMP & SHARED(dn_dt_old,dux_dt_old,duy_dt_old) PRIVATE(i,j)
!$OMP DO

do i = 1,Nh
  do j = 1,Ny
    ! Density Equation Evolution.
    nk_new(i,j) = nk(i,j) + ( (3.0d0/2.0d0)*dn_dt_new(i,j) - (1.0d0/2.0d0)*dn_dt_old(i,j) )*dt
    ! Momentum Equation Evolution.
    ukx_new(i,j) = ukx(i,j) + ( (3.0d0/2.0d0)*dux_dt_new(i,j) - (1.0d0/2.0d0)*dux_dt_old(i,j) )*dt
    uky_new(i,j) = uky(i,j) + ( (3.0d0/2.0d0)*duy_dt_new(i,j) - (1.0d0/2.0d0)*duy_dt_old(i,j) )*dt
  end do
end do

!$OMP END DO
!$OMP END PARALLEL

return

end subroutine ab2coh


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: cosqmi.f,v 1.2 2006-11-21 01:10:17 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DCOSQMI(N,WSAVE,LENSAV,IER)
      DOUBLE PRECISION PIH
      DOUBLE PRECISION DT
      DOUBLE PRECISION FK
      INTEGER N,LENSAV,IER
      DOUBLE PRECISION WSAVE(LENSAV)
C
      IER = 0
C
      IF (LENSAV.LT.2*N+INT(LOG(DBLE(N)))+4) THEN
          IER = 2
          CALL DXERFFT('COSQMI',3)
          GO TO 300
      END IF
C
      PIH = 2.D0*ATAN(1.D0)
      DT = PIH/DBLE(N)
      FK = 0.D0
      DO 101 K = 1,N
          FK = FK + 1.D0
          WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      LNSV = N + INT(LOG(DBLE(N))) + 4
      CALL DRFFTMI(N,WSAVE(N+1),LNSV,IER1)
      IF (IER1.NE.0) THEN
          IER = 20
          CALL DXERFFT('COSQMI',-5)
      END IF
  300 CONTINUE
      RETURN
      END


      subroutine compute_sx(n_a1,n_iPHI,n_iPI,n_rPHI,n_rPI,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_a1(Nx)
      real*8 n_iPHI(Nx)
      real*8 n_iPI(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rPI(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = -0.1D1 * (n_rPI(i) * n_rPHI(i) + n_iPI(i) * n_iPHI(i)) / n_a1
     #(i)
      res(i)=qb
      end do
      END


!! CALCULO DE ONDAS GRAVITACIONALES !! Mario Gonzalez Carpintero ft Diego Valledor Fuertes

program main

    use global

    !! PARAMETROS Y VARIABLES !!
    integer Nxx, Ntt                      !variables locales
    integer every_scalar_t, every_array_t !variables locales

    NAMELIST / parameters / xmin, xmax, resolution, Nxx, Ntt, courant, &
                            every_scalar_t, every_array_t, &
                            amplitude, sigma, x0, &
                            Boundaries, Metric

    open(2, file = 'input.par', status = 'old', action = 'read')
    read(2, nml = parameters, IOSTAT = ios)
    close(2)

    pii             = 4.0d0*atan(1.0d0)       !aux
    Nx              = 2**(resolution - 1)*Nxx !divisiones espaciales
    Nt              = 2**(resolution - 1)*Ntt !divisiones temporales
    every_scalar    = 2**(resolution - 1)*every_scalar_t !unidad para guardar escalares
    every_array     = 2**(resolution - 1)*every_array_t  !unidad para guardar arrays

    call CPU_TIME(cpu_inicio)
    call principal
    call CPU_TIME(cpu_fin)

    print *
    print *, 'PROGRAM GRAVITATIONAL-WAVE HAS FINISHED'
    print *, 'CPU time has been =', cpu_fin - cpu_inicio
    print *

end program main


subroutine sail_sensgeom(tts,tto,psi, &
        cts,cto,ctscto,dso)

    implicit none
    REAL*8, INTENT(in) :: tts,tto,psi
    REAL*8, INTENT(out) :: cts,cto,ctscto,dso

    real*8 :: pi,rd
    common /angle/ pi,rd
    REAL*8 :: tants,tanto,cospsi

        cts    = COS(rd*tts)
        cto    = COS(rd*tto)
        ctscto = cts*cto
        tants  = TAN(rd*tts)
        tanto  = TAN(rd*tto)
        cospsi = COS(rd*psi)
        dso    = SQRT(tants*tants+tanto*tanto-2.*tants*tanto*cospsi)

        return
end subroutine sail_sensgeom


subroutine Poisson_2D_double_precision(Lx,Ly,Nnx,Nny,lambda,f,chii)

! Include modules defined by mkl_poisson.f90 and mkl_dfti.f90 header files
use mkl_poisson

implicit none
integer, intent(in) :: Nnx,Nny
real(8), intent(in) :: Lx,Ly,lambda
real(8), dimension(Nnx,Nny), intent(in)  :: f
real(8), dimension(Nnx,Nny), intent(out) :: chii

double precision pi
parameter(pi=3.14159265358979324D0)

integer nx, ny, stat
integer ipar(128)
double precision ax, bx, ay, by, q
double precision bd_ax(Nny), bd_bx(Nny), bd_ay(Nnx), bd_by(Nnx)
double precision dpar(13*(Nnx-1)/2+7)
type(DFTI_DESCRIPTOR), pointer :: xhandle
character(4) BCtype

nx=Nnx-1
ny=Nny-1

! Defining the rectangular domain 0<x<Lx, 0<y<Ly for 2D Poisson Solver
ax=0.0D0
bx=Lx
ay=0.0D0
by=Ly

!*******************************************************************************
! Setting the coefficient q to 0.
! Note that this is the way to use Helmholtz Solver to solve Poisson problem!
!*******************************************************************************
q=(lambda*lambda)

!******************************************************************************
! NOTE THE SIGN CONVENTION USED FOR THE POISSON EQUATION!!!!!!!!!!!!!!!!!!!!!!!
!******************************************************************************

!******************************************************************************
! BOUNDARY CONDITIONS
!******************************************************************************
BCtype = 'DDDD'
!bd_ax(:) = 0.0D0
!bd_bx(:) = 0.0D0
!bd_ay(:) = 0.0D0
!bd_by(:) = 0.0D0

bd_ax(:) = chii(1,:)
bd_bx(:) = chii(Nnx,:)
bd_ay(:) = chii(:,1)
bd_by(:) = chii(:,Nny)
! NOTE:
!print *, ' The SOLUTION depends NOT on boundary values of the rhs for Dirichlet !!!!!!!!!!!!!!'
!f(1,:) = 1.d10
!write(*,*) f(1,:)
!print *, ' The SOLUTION depends on boundary values of the rhs for Neumann !!!!!!!!!!!!!!!!!!!!'
!f(:,1) = 1.d10
!write(*,*) f(:,1)

! Initializing ipar array to make it free from garbage
ipar(:)=0

! Initializing simple data structures of Poisson Library for 2D Poisson Solver
call d_init_Helmholtz_2D(ax, bx, ay, by, nx, ny, BCtype, q, ipar, dpar, stat)
if (stat.ne.0) stop 111

! Initializing complex data structures of Poisson Library for 2D Poisson Solver
! NOTE: Right-hand side f may be altered after the Commit step. If you want
! to keep it, you should save it in another memory location!
call d_commit_Helmholtz_2D(f, bd_ax, bd_bx, bd_ay, bd_by, xhandle, ipar, dpar, stat)
if (stat.ne.0) stop 222

! Computing the approximate solution of 2D Poisson problem
! NOTE: Boundary data stored in the arrays bd_ax, bd_bx, bd_ay, bd_by
! should not be changed between the Commit step and the subsequent call to
! the Solver routine! Otherwise the results may be wrong.
call d_Helmholtz_2D(f, bd_ax, bd_bx, bd_ay, bd_by, xhandle, ipar, dpar, stat)
if (stat.ne.0) stop 333

! Cleaning the memory used by xhandle
call free_Helmholtz_2D(xhandle, ipar, stat)
if (stat.ne.0) stop 444
! Now we can use xhandle to solve another 2D Poisson problem

chii = f

! Free MKL memory if any was allocated
call mkl_free_buffers

end