      subroutine sed_1d(time,nstep,xpos, &
                        eblast,omega_in,xgeom_in, &
                        rho0,vel0,ener0,pres0,cs0,gam0, &
                        rshock,rho2,u2,e2,p2,cs2,rvacuum, &
                        den,ener,pres,vel,cs)
      implicit none

! this routine produces 1d solutions for a sedov blast wave propagating
! through a density gradient rho = rho**(-omega)
! in planar, cylindrical or spherical geometry
! for the standard, transitional and vaccum cases:

! standard     : a nonzero solution extends from the shock to the origin, where the pressure is finite.
! transitional : a nonzero solution extends from the shock to the origin, where the pressure vanishes.
! vacuum       : a nonzero solution extends from the shock to a boundary point, where the density vanishes.

! input:
! time     = temporal point where solution is desired seconds
! xpos(i)  = spatial points where solution is desired cm
! eblast   = energy of blast erg
! rho0     = ambient density g/cm**3    rho = rho0 * r**(-omega_in)
! omegain  = density power law exponent rho = rho0 * r**(-omega_in)
! vel0     = ambient material speed cm/s
! pres0    = ambient pressure erg/cm**3
! cs0      = ambient sound speed cm/s
! gam0     = gamma law equation of state
! xgeom_in = geometry factor, 3=spherical, 2=cylindircal, 1=planar

! for efficiency (i.e., doing the energy integrals only once),
! this routine returns the solution for an array of spatial points
! at the desired time point.

! output:
! den(i)  = density  g/cm**3
! ener(i) = specific internal energy erg/g
! pres(i) = presssure erg/cm**3
! vel(i)  = velocity cm/s
! cs(i)   = sound speed cm/s

! this routine is based upon two papers:
! "evaluation of the sedov-von neumann-taylor blast wave solution"
! jim kamm, la-ur-00-6055
! "the sedov self-similiar point blast solutions in nonuniform media"
! david book, shock waves, 4, 1, 1994

! although the ordinary differential equations are analytic,
! the sedov expressions appear to become singular for various
! combinations of parameters and at the lower limits of the integration
! range. all these singularies are removable and done so by this routine.

! real*16 because the real*8 implementations run out of precision, for example,
! "near" the origin in the standard case or the transition region in the vacuum case.

! declare the pass
      integer      ::  nstep
      real*16      ::  time,xpos(*), &
                       eblast,rho0,omega_in,vel0,ener0,pres0,cs0, &
                       gam0,xgeom_in,rshock,rho2,u2,e2,p2,cs2,rvacuum, &
                       den(*),ener(*),pres(*),vel(*),cs(*)

! local variables
      external     ::  midpnt,midpowl,midpowl2,sed_v_find,sed_r_find, &
                       efun01,efun02
      integer      ::  i
      real*16      ::  efun01,efun02,eval1,eval2
      real*16      ::  v0,v2,vstar,vmin,alpha,us, &
                       zeroin,sed_v_find,sed_r_find, &
                       vat,l_fun,dlamdv,f_fun,g_fun,h_fun, &
                       denom2,denom3,rho1

! eps controls the integration accuracy, don't get too greedy or the number
! of function evaluations required kills.
! eps2 controls the root find accuracy
! osmall controls the size of transition regions

      integer, parameter :: iprint = 1
      real*16, parameter :: eps    = 1.0q-10, &
                            eps2   = 1.0q-28, &
                            osmall = 1.0q-4, &
                            pi     = 3.1415926535897932384626433832795029q0

! common block communication
      include 'sedov3_qp.dek'

! common block communication with the integration stepper
      real*16        :: gam_int
      common /cmidp/    gam_int

! popular formats
 87   format(1x,1p10e14.6)
 88   format(1x,8(a7,1pe14.6,' '))

! initialize the solution
      do i=1,nstep
       den(i)  = 0.0q0
       vel(i)  = 0.0q0
       pres(i) = 0.0q0
       ener(i) = 0.0q0
       cs(i)   = 0.0q0
      end do

! return on unphysical cases
! infinite mass
      if (omega_in .ge. xgeom_in) return

! transfer the pass to common block and create some frequent combinations
      gamma  = gam0
      gamm1  = gamma - 1.0q0
      gamp1  = gamma + 1.0q0
      gpogm  = gamp1 / gamm1
      xgeom  = xgeom_in
      omega  = omega_in
      xg2    = xgeom + 2.0q0 - omega
      denom2 = 2.0q0*gamm1 + xgeom - gamma*omega
      denom3 = xgeom * (2.0q0 - gamma) - omega

! post shock location v2 and location of transitional point vstar
! kamm equation 18 and 19

      v2    = 4.0q0 / (xg2 * gamp1)
      vstar = 2.0q0 / (gamm1*xgeom + 2.0q0)

! set logicals that determines the type of solution

      lstandard     = .false.
      ltransitional = .false.
      lvacuum       = .false.

      if (abs(v2 - vstar) .le. osmall) then
       ltransitional = .true.
       if (iprint .eq. 1) write(6,*) 'transitional'
      else if (v2 .lt. vstar - osmall) then
       lstandard = .true.
       if (iprint .eq. 1) write(6,*) 'standard'
      else if (v2 .gt. vstar + osmall) then
       lvacuum = .true.
       if (iprint .eq. 1) write(6,*) 'vacuum'
      end if

! two apparent singularies, book's notation for omega2 and omega3
! resetting denom2 and denom3 is harmless as these two singularities are explicitely addressed

      lomega2 = .false.
      lomega3 = .false.

      if (abs(denom2) .le. osmall) then
       if (iprint .eq. 1) write(6,'(a,1pe12.4)') 'omega = omega2 ',denom2
       lomega2 = .true.
       denom2  = 1.0q-8

      else if (abs(denom3) .le. osmall) then
       if (iprint .eq. 1) write(6,'(a,1pe12.4)') 'omega = omega3 ',denom3
       lomega3 = .true.
       denom3  = 1.0q-8
      end if

! various exponents, kamm equations 42-47
! in terms of book's notation:
! a0=beta6 a1=beta1  a2=-beta2 a3=beta3 a4=beta4 a5=-beta5

      a0  = 2.0q0/xg2
      a2  = -gamm1/denom2
      a1  =  xg2*gamma/(2.0q0 + xgeom*gamm1) * &
            (((2.0q0*(xgeom*(2.0q0-gamma) - omega))/(gamma*xg2*xg2))-a2)
      a3  = (xgeom - omega) / denom2
      a4  = xg2 * (xgeom - omega) * a1 /denom3
      a5  = (omega*gamp1 - 2.0q0*xgeom)/denom3

! frequent combinations, kamm equations 33-37
      a_val = 0.25q0 * xg2 * gamp1
      b_val = gpogm
      c_val = 0.5q0 * xg2 * gamma
      d_val = (xg2 * gamp1)/(xg2*gamp1 - 2.0q0*(2.0q0 + xgeom*gamm1))
      e_val = 0.5q0 * (2.0q0 + xgeom * gamm1)

! evaluate the energy integrals
! the transitional case can be done by hand; save some cpu cycles
! kamm equations 80, 81, and 85

      if (ltransitional) then

       eval2 = gamp1/(xgeom*(gamm1*xgeom + 2.0q0)**2)
       eval1 = 2.0q0/gamm1 * eval2
       alpha = gpogm * 2**(xgeom)/(xgeom*(gamm1*xgeom + 2.0q0)**2)
       if (int(xgeom) .ne. 1) alpha = pi * alpha

! for the standard or vacuum cases
! v0 = post-shock origin v0 and vv = vacuum boundary vv
! set the radius corespondin to vv to zero for now
! kamm equations 18, and 28.

      else
       v0  = 2.0q0 / (xg2 * gamma)
       vv  = 2.0q0 / xg2
       rvv = 0.0q0
       if (lstandard) vmin = v0
       if (lvacuum)   vmin  = vv

! the first energy integral
! in the standard case the term (c_val*v - 1) might be singular at v=vmin

       if (lstandard) then
        gam_int = a3 - a2*xg2 - 1.0q0
        if (gam_int .ge. 0) then
         call qromo(efun01,vmin,v2,eps,eval1,midpnt)
        else
         gam_int = abs(gam_int)
         call qromo(efun01,vmin,v2,eps,eval1,midpowl)
        end if

! in the vacuum case the term (1 - c_val/gamma*v) might be singular at v=vmin

       else if (lvacuum) then
        gam_int = a5
        if (gam_int .ge. 0) then
         call qromo(efun01,vmin,v2,eps,eval1,midpnt)
        else
         gam_int = abs(gam_int)
         call qromo(efun01,vmin,v2,eps,eval1,midpowl2)
        end if
       end if

! the second energy integral
! in the standard case the term (c_val*v - 1) might be singular at v=vmin

       if (lstandard) then
        gam_int = a3 - a2*xg2 - 2.0q0
        if (gam_int .ge. 0) then
         call qromo(efun02,vmin,v2,eps,eval2,midpnt)
        else
         gam_int = abs(gam_int)
         call qromo(efun02,vmin,v2,eps,eval2,midpowl)
        end if

! in the vacuum case the term (1 - c_val/gamma*v) might be singular at v=vmin

       else if (lvacuum) then
        gam_int = a5
        if (gam_int .ge. 0) then
         call qromo(efun02,vmin,v2,eps,eval2,midpnt)
        else
         gam_int = abs(gam_int)
         call qromo(efun02,vmin,v2,eps,eval2,midpowl2)
        end if
       end if

! kamm, bolstad & timmes equation 57 for alpha
       if (int(xgeom) .eq. 1) then

! bug reported Irina Sagert march 2019
!        alpha = 0.5q0*eval1 + eval2/gamm1

        alpha = eval1 + 2.0q0*eval2/gamm1

       else
        alpha = (xgeom - 1.0q0) * pi * (eval1 + 2.0q0 * eval2/gamm1)
       end if
      end if

! write what we have for the energy integrals
      if (iprint .eq. 1) &
          write(6,88) 'xgeom =',xgeom,'gamma=',gamma, &
                      'omega =',omega,'alpha =',alpha, &
                      'j1    =',eval1,'j2    =',eval2

! immediate post-shock values
! kamm page 14 or equations 14, 16, 5, 13
! r2 = shock position, u2 = shock speed, rho1 = pre-shock density,
! u2 = post-shock material speed, rho2 = post-shock density,
! p2 = post-shock pressure, e2 = post-shoock specific internal energy,
! and cs2 = post-shock sound speed

      r2   = (eblast/(alpha*rho0))**(1.0q0/xg2) * time**(2.0q0/xg2)
      rshock = r2
      us   = (2.0q0/xg2) * r2 / time
      rho1 = rho0 * r2**(-omega)
      u2   = 2.0q0 * us / gamp1
      rho2 = gpogm * rho1
      p2   = 2.0q0 * rho1 * us**2 / gamp1
      e2   = p2/(gamm1*rho2)
      cs2  = sqrt(gamma*p2/rho2)

! find the radius corresponding to vv
       if (lvacuum)   then
        vwant = vv
        rvv = zeroin(0.0q0,r2,sed_r_find,eps2)
        rvacuum = rvv
       end if

! write a summary
      if (lstandard .and. iprint .eq. 1) &
           write(6,88) 'r2    =',r2,'rho2  =',rho2, &
                       'u2    =',u2,'e2    =',e2, &
                       'p2    =',p2,'cs2   =',cs2

      if (lvacuum .and. iprint .eq. 1) &
           write(6,88) &
                       'rv    =',rvv, &
                       'r2    =',r2,'rho2  =',rho2, &
                       'u2    =',u2,'e2    =',e2, &
                       'p2    =',p2,'cs2   =',cs2

! now start the loop over spatial positions
      do i=1,nstep
       rwant  = xpos(i)

! if we are upstream from the shock front
       if (rwant .gt. r2) then
        den(i)  = rho0 * rwant**(-omega)
        vel(i)  = vel0
        pres(i) = pres0
        ener(i) = ener0
        cs(i)   = cs0

! if we are between the origin and the shock front
! find the correct similarity value for this radius in the standard or vacuum cases
       else
        if (lstandard) then
         vat = zeroin(0.90q0*v0,v2,sed_v_find,eps2)
        else if (lvacuum) then
         vat = zeroin(v2,1.2q0*vv,sed_v_find,eps2)
        end if

! the physical solution
        call sedov_funcs(vat,l_fun,dlamdv,f_fun,g_fun,h_fun)
        den(i)   = rho2 * g_fun
        vel(i)   = u2   * f_fun
        pres(i)  = p2   * h_fun
!        den(i)   = g_fun
!        vel(i)   = f_fun
!        pres(i)  = h_fun
        ener(i)  = 0.0q0
        cs(i)    = 0.0q0
        if (den(i) .ne. 0.0) then
         ener(i)  = pres(i) / (gamm1 * den(i))
         cs(i)    = sqrt(gamma * pres(i)/den(i))
        end if
       end if

! end of loop over positions
      enddo

      return
      end subroutine sed_1d

      real*16 function efun01(v)
      implicit none
      save

! evaluates the first energy integrand, kamm equations 67 and 10.
! the (c_val*v - 1) term might be singular at v=vmin in the standard case.
! the (1 - c_val/gamma * v) term might be singular at v=vmin in the vacuum case.
! due care should be taken for these removable singularities by the integrator.

! declare the pass
      real*16 :: v

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16 :: l_fun,dlamdv,f_fun,g_fun,h_fun

! go
      call sedov_funcs(v,l_fun,dlamdv,f_fun,g_fun,h_fun)
      efun01 = dlamdv * l_fun**(xgeom + 1.0q0) * gpogm * g_fun * v**2

      return
      end function efun01

      real*16 function efun02(v)
      implicit none
      save

! evaluates the second energy integrand, kamm equations 68 and 11.
! the (c_val*v - 1) term might be singular at v=vmin in the standard case.
! the (1 - c_val/gamma * v) term might be singular at v=vmin in the vacuum case.
! due care should be taken for these removable singularities by the integrator.

! declare the pass
      real*16  :: v

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16 :: l_fun,dlamdv,f_fun,g_fun,h_fun,z

! go
      call sedov_funcs(v,l_fun,dlamdv,f_fun,g_fun,h_fun)
      z = 8.0q0/( (xgeom + 2.0q0 - omega)**2 * gamp1)
      efun02 = dlamdv * l_fun**(xgeom - 1.0q0 ) * h_fun * z

      return
      end function efun02

      real*16 function sed_v_find(v)
      implicit none
      save

! given corresponding physical distances, find the similarity variable v
! kamm equation 38 as a root find

! declare the pass
      real*16  :: v

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16 :: l_fun,dlamdv,f_fun,g_fun,h_fun

      call sedov_funcs(v,l_fun,dlamdv,f_fun,g_fun,h_fun)
      sed_v_find = r2*l_fun - rwant

      return
      end function sed_v_find

      real*16 function sed_r_find(r)
      implicit none
      save

! given the similarity variable v, find the corresponding physical distance
! kamm equation 38 as a root find

! declare the pass
      real*16  :: r

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16 :: l_fun,dlamdv,f_fun,g_fun,h_fun

      call sedov_funcs(vwant,l_fun,dlamdv,f_fun,g_fun,h_fun)
      sed_r_find = r2*l_fun - r

      return
      end function sed_r_find

      real*16 function sed_lam_find(v)
      implicit none
      save

! given the similarity variable v, find the corresponding physical distance
! kamm equation 38 as a root find

! declare the pass
      real*16  :: v

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16 :: l_fun,dlamdv,f_fun,g_fun,h_fun

      call sedov_funcs(v,l_fun,dlamdv,f_fun,g_fun,h_fun)
      sed_lam_find = l_fun - xlam_want

      return
      end function sed_lam_find

      subroutine sedov_funcs(v,l_fun,dlamdv,f_fun,g_fun,h_fun)
      implicit none
      save

! given the similarity variable v, returns functions
! lambda, f, g, and h and the derivative of lambda with v dlamdv

! although the ordinary differential equations are analytic,
! the sedov expressions appear to become singular for various
! combinations of parameters and at the lower limits of the integration
! range. all these singularies are removable and done so by this routine.

! declare the pass
      real*16            :: v,l_fun,dlamdv,f_fun,g_fun,h_fun

! common block communication
      include 'sedov3_qp.dek'

! local variables
      real*16            :: x1,x2,x3,x4,dx1dv,dx2dv,dx3dv,dx4dv, &
                            cbag,ebag,beta0,pp1,pp2,pp3,pp4,c2,c6,y,z, &
                            dpp2dv
      real*16, parameter :: eps = 1.0q-30

! frequent combinations and their derivative with v
! kamm equation 29-32, x4 a bit different to save a divide
! x1 is book's F

       x1 = a_val * v
       dx1dv = a_val

       cbag = max(eps, c_val * v - 1.0q0)
       x2 = b_val * cbag
       dx2dv = b_val * c_val

       ebag = 1.0q0 - e_val * v
       x3 = d_val * ebag
       dx3dv = -d_val * e_val

       x4 = b_val * (1.0q0 - 0.5q0 * xg2 *v)
       dx4dv = -b_val * 0.5q0 * xg2

! transition region between standard and vacuum cases
! kamm page 15 or equations 88-92
! lambda = l_fun is book's zeta
! f_fun is books V, g_fun is book's D, h_fun is book's P

      if (ltransitional) then
       l_fun  = rwant/r2
       dlamdv = 0.0q0
       f_fun  = l_fun
       g_fun  = l_fun**(xgeom - 2.0q0)
       h_fun  = l_fun**xgeom

! for the vacuum case in the hole
      else if (lvacuum .and. rwant .lt. rvv) then

       l_fun  = 0.0q0
       dlamdv = 0.0q0
       f_fun  = 0.0q0
       g_fun  = 0.0q0
       h_fun  = 0.0q0

! omega = omega2 = (2*(gamma -1) + xgeom)/gamma case, denom2 = 0
! book expressions 20-22

      else if (lomega2) then

       beta0 = 1.0q0/(2.0q0 * e_val)
       pp1   = gamm1 * beta0
       c6    = 0.5q0 * gamp1
       c2    = c6/gamma
       y     = 1.0q0/(x1 - c2)
       z     = (1.0q0 - x1)*y
       pp2   = gamp1 * beta0 * z
       dpp2dv = -gamp1 * beta0 * dx1dv * y * (1.0q0 + z)
       pp3   = (4.0q0 - xgeom - 2.0q0*gamma) * beta0
       pp4   = -xgeom * gamma * beta0

       l_fun = x1**(-a0) * x2**(pp1) * exp(pp2)
       dlamdv = (-a0*dx1dv/x1 + pp1*dx2dv/x2 + dpp2dv) * l_fun
       f_fun = x1 * l_fun
       g_fun = x1**(a0*omega) * x2**pp3 * x4**a5 * exp(-2.0q0*pp2)
       h_fun = x1**(a0*xgeom) * x2**pp4 * x4**(1.0q0 + a5)

! omega = omega3 = xgeom*(2 - gamma) case, denom3 = 0
! book expressions 23-25

      else if (lomega3) then

       beta0 = 1.0q0/(2.0q0 * e_val)
       pp1   = a3 + omega * a2
       pp2   = 1.0q0 - 4.0q0 * beta0
       c6    = 0.5q0 * gamp1
       pp3   = -xgeom * gamma * gamp1 * beta0 * (1.0q0 - x1)/(c6 - x1)
       pp4   = 2.0q0 * (xgeom * gamm1 - gamma) * beta0

       l_fun = x1**(-a0) * x2**(-a2) * x4**(-a1)
       dlamdv = -(a0*dx1dv/x1 + a2*dx2dv/x2 + a1*dx4dv/x4) * l_fun
       f_fun = x1 * l_fun
       g_fun = x1**(a0*omega) * x2**pp1 * x4**pp2 * exp(pp3)
       h_fun = x1**(a0*xgeom) * x4**pp4 * exp(pp3)

! for the standard or vacuum case not in the hole
! kamm equations 38-41

      else
       l_fun = x1**(-a0) * x2**(-a2) * x3**(-a1)
       dlamdv = -(a0*dx1dv/x1 + a2*dx2dv/x2 + a1*dx3dv/x3) * l_fun
       f_fun = x1 * l_fun
       if (x4 .eq. 0.0 .and. a5 .lt. 0.0) then
        g_fun = 1.0q30
       else
        g_fun = x1**(a0*omega)*x2**(a3+a2*omega)*x3**(a4+a1*omega)*x4**a5
       end if
       h_fun = x1**(a0*xgeom)*x3**(a4+a1*(omega-2.0q0))*x4**(1.0q0 + a5)
      end if

      return
      end subroutine sedov_funcs

      subroutine midpnt(func,a,b,s,n)
      implicit none
      save

! this routine computes the n'th stage of refinement of an extended midpoint
! rule. func is input as the name of the function to be integrated between
! limits a and b. when called with n=1, the routine returns as s the crudest
! estimate of the integralof func from a to b. subsequent calls with n=2,3...
! improve the accuracy of s by adding 2/3*3**(n-1) addtional interior points.

! declare the pass
      external       :: func
      integer        :: n
      real*16        :: func,a,b,s

! local variables

      integer        :: it,j
      real*16        :: tnm,del,ddel,x,asum

      if (n.eq.1) then
       s  = (b-a) * func(0.5q0*(a+b))
      else
       it   = 3**(n-2)
       tnm  = it
       del  = (b-a)/(3.0q0*tnm)
       ddel = del + del
       x    = a + (0.5q0 * del)
       asum  = 0.0q0
       do j=1,it
        asum = asum + func(x)
        x   = x + ddel
        asum = asum + func(x)
        x   = x + del
       enddo
       s  = (s + ((b-a) * asum/tnm)) / 3.0q0
      end if
      return
      end  subroutine midpnt

      subroutine midpowl(funk,aa,bb,s,n)
      implicit none
      save

! this routine is an exact replacement for midpnt, except that it allows for
! an integrable power-law singularity of the form (x - a)**(-gam_int)
! at the lower limit aa for 0 < gam_int < 1.

! declare the pass
      external       :: funk
      integer        :: n
      real*16        :: funk,aa,bb,s

! local variables
      integer        :: it,j
      real*16        :: func,a,b,tnm,del,ddel,x,asum

! common block communication
      real*16          gam_int
      common /cmidp/   gam_int

! statement function,  recipe equation 4.4.3
      func(x) = 1.0q0/(1.0q0 - gam_int) * x**(gam_int/(1.0q0 - gam_int)) &
                * funk(x**(1.0q0/(1.0q0 - gam_int)) + aa)

      b = (bb - aa)**(1.0q0 - gam_int)
      a = 0.0q0

! now exactly as midpnt
      if (n .eq. 1) then
       s = (b-a) * func(0.5q0*(a+b))
      else
       it   = 3**(n-2)
       tnm = it
       del = (b-a)/(3.0q0*tnm)
       ddel = del + del
       x = a + (0.5q0 * del)
       asum = 0.0q0
       do j=1,it
        asum = asum + func(x)
        x   = x + ddel
        asum = asum + func(x)
        x   = x + del
       enddo
       s = (s + ((b-a) * asum/tnm)) / 3.0q0
      end if
      return
      end subroutine midpowl

      subroutine midpowl2(funk,aa,bb,s,n)
      implicit none
      save

! this routine is an exact replacement for midpnt, except that it allows for
! an integrable power-law singularity of the form (a - x)**(-gam_int)
! at the lower limit aa for 0 < gam_int < 1.

! declare the pass
      external       :: funk
      integer        :: n
      real*16        :: funk,aa,bb,s

! local variables

      integer        :: it,j
      real*16        :: func,a,b,tnm,del,ddel,x,asum

! common block communication
      real*16          gam_int
      common /cmidp/   gam_int

! statement function and recipe equation 4.4.3
      func(x) = 1.0q0/(gam_int - 1.0q0) * x**(gam_int/(1.0q0 - gam_int)) &
                * funk(aa - x**(1.0q0/(1.0q0 - gam_int)))

      b = (aa - bb)**(1.0q0 - gam_int)
      a = 0.0q0

! now exactly as midpnt
      if (n .eq. 1) then
       s = (b-a) * func(0.5q0*(a+b))
      else
       it   = 3**(n-2)
       tnm = it
       del = (b-a)/(3.0q0*tnm)
       ddel = del + del
       x = a + (0.5q0 * del)

       asum = 0.0q0
       do j=1,it
        asum = asum + func(x)
        x   = x + ddel
        asum = asum + func(x)
        x   = x + del
       enddo
       s = (s + ((b-a) * asum/tnm)) / 3.0q0
      end if
      return
      end subroutine midpowl2

      subroutine qromo(func,a,b,eps,ss,choose)
      implicit none
      save

! this routine returns as s the integral of the function func from a to b
! with fractional accuracy eps.
! jmax limits the number of steps; nsteps = 3**(jmax-1)
! integration is done via romberg algorithm.

! it is assumed the call to choose triples the number of steps on each call
! and that its error series contains only even powers of the number of steps.
! the external choose may be any of the above drivers, i.e midpnt,midinf...

! declare the pass
      external           :: choose,func
      real*16            :: a,b,ss,eps,func

! local variables
      integer            :: i,j
      integer, parameter :: jmax=15, jmaxp=jmax+1, k=5, km=k-1
      real*16            :: s(jmaxp),h(jmaxp),dss

      h(1) = 1.0q0
      do j=1,jmax
       call choose(func,a,b,s(j),j)
       if (j .ge. k) then
        call polint(h(j-km),s(j-km),k,0.0q0,ss,dss)
        if (abs(dss) .le. eps*abs(ss)) return
       end if
       s(j+1) = s(j)
       h(j+1) = h(j)/9.0q0
      enddo
      write(6,*)  'too many steps in qromo'
      return
      end subroutine qromo

      subroutine polint(xa,ya,n,x,y,dy)
      implicit none
      save

! given arrays xa and ya of length n and a value x, this routine returns a
! value y and an error estimate dy. if p(x) is the polynomial of degree n-1
! such that ya = p(xa) ya then the returned value is y = p(x)

! declare the pass
      integer            :: n
      real*16            :: xa(n),ya(n),x,y,dy

! local variables
      integer            :: ns,i,m
      integer, parameter :: nmax=20
      real*16            :: c(nmax),d(nmax),dif,dift,ho,hp,w,den

! find the index ns of the closest table entry; initialize the c and d tables
      ns  = 1
      dif = abs(x - xa(1))
      do i=1,n
       dift = abs(x - xa(i))
       if (dift .lt. dif) then
        ns  = i
        dif = dift
       end if
       c(i)  = ya(i)
       d(i)  = ya(i)
      enddo

! first guess for y
      y = ya(ns)

! for each column of the table, loop over the c's and d's and update them
      ns = ns - 1
      do m=1,n-1
       do i=1,n-m
        ho   = xa(i) - x
        hp   = xa(i+m) - x
        w    = c(i+1) - d(i)
        den  = ho - hp
        if (den .eq. 0.0) stop ' 2 xa entries are the same in polint'
        den  = w/den
        d(i) = hp * den
        c(i) = ho * den
       enddo

! after each column is completed, decide which correction c or d, to add
! to the accumulating value of y, that is, which path to take in the table
! by forking up or down. ns is updated as we go to keep track of where we
! are. the last dy added is the error indicator.
       if (2*ns .lt. n-m) then
        dy = c(ns+1)
       else
        dy = d(ns)
        ns = ns - 1
       end if
       y = y + dy
      enddo
      return
      end subroutine polint

      real*16 function zeroin( ax, bx, f, tol)
      implicit real*16 (a-h,o-z)

!-----------------------------------------------------------------------
!
! This subroutine solves for a zero of the function  f(x)  in the
! interval ax,bx.
!
!  input..
!
!  ax     left endpoint of initial interval
!  bx     right endpoint of initial interval
!  f      function subprogram which evaluates f(x) for any x in
!         the interval  ax,bx
!  tol    desired length of the interval of uncertainty of the
!         final result ( .ge. 0.0q0)
!
!
!  output..
!
!  zeroin abcissa approximating a zero of  f  in the interval ax,bx
!
!
!      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
!  without  a  check.  zeroin  returns a zero  x  in the given interval
!  ax,bx  to within a tolerance  4*macheps*abs(x) + tol, where macheps
!  is the relative machine precision.
!      this function subprogram is a slightly  modified  translation  of
!  the algol 60 procedure  zero  given in  richard brent, algorithms for
!  minimization without derivatives, prentice - hall, inc. (1973).
!
!-----------------------------------------------------------------------

! .. call list variables

      real*16  :: ax, bx, f, tol, a, b, c, d, e, eps, fa, fb, fc, tol1, xm, p, q, r, s
      external :: f

!----------------------------------------------------------------------

!
!  compute eps, the relative machine precision
!
      eps = 1.0q0
   10 eps = eps/2.0q0
      tol1 = 1.0q0 + eps
      if (tol1 .gt. 1.0q0) go to 10
!
! initialization
!
      a = ax
      b = bx
      fa = f(a)
      fb = f(b)

!      write(6,'(a,1p2e40.32)') ' fa fb ',fa, fb

!
! begin step
!
   20 c = a
      fc = fa
      d = b - a
      e = d
   30 if ( abs(fc) .ge.  abs(fb)) go to 40
      a = b
      b = c
      c = a
      fa = fb
      fb = fc
      fc = fa
!
! convergence test
!
   40 tol1 = 2.0q0*eps*abs(b) + 0.5q0*tol
      xm = 0.5q0*(c - b)

!      write(6,'(a,1p2e40.32)') ' xm tol1 ',abs(xm), tol1
!      write(6,*)

      if (abs(xm) .le. tol1) go to 90
      if (fb .eq. 0.0q0) go to 90
!
! is bisection necessary?
!
      if (abs(e) .lt. tol1) go to 70
      if (abs(fa) .le. abs(fb)) go to 70
!
! is quadratic interpolation possible?
!
      if (a .ne. c) go to 50
!
! linear interpolation
!
      s = fb/fa
      p = 2.0q0*xm*s
      q = 1.0q0 - s
      go to 60
!
! inverse quadratic interpolation
!
   50 q = fa/fc
      r = fb/fc
      s = fb/fa
      p = s*(2.0q0*xm*q*(q - r) - (b - a)*(r - 1.0q0))
      q = (q - 1.0q0)*(r - 1.0q0)*(s - 1.0q0)
!
! adjust signs
!
   60 if (p .gt. 0.0q0) q = -q
      p = abs(p)
!
! is interpolation acceptable?
!
      if ((2.0q0*p) .ge. (3.0q0*xm*q - abs(tol1*q))) go to 70
      if (p .ge. abs(0.5q0*e*q)) go to 70
      e = d
      d = p/q
      go to 80
!
! bisection
!
   70 d = xm
      e = d
!
! complete step
!
   80 a = b
      fa = fb
      if (abs(d) .gt. tol1) b = b + d
      if (abs(d) .le. tol1) b = b + Sign(tol1, xm)
      fb = f(b)
      if ((fb*(fc/abs(fc))) .gt. 0.0q0) go to 20
      go to 30
!
! done
!
   90 zeroin = b

      return
      end function zeroin

      real*16 function value(string)
      implicit none
      save

! this routine takes a character string and converts it to a real number.
! on error during the conversion, a fortran stop is issued

! declare
      logical            :: pflag
      character*(*)      :: string
      integer            :: noblnk,long,ipoint,power,psign,j,z,i
      integer, parameter :: iten = 10
      real*16            :: x,sign,factor,temp
      real*16, parameter :: rten =  10.0q0
      character*1, parameter :: plus = '+'  , minus = '-' , decmal = '.'   , &
                                blank = ' ' , &
                                se  = 'e'   , sd  = 'd'   , sq = 'q'       , &
                                se1 = 'E'   , sd1 = 'D'   , sq1 ='Q'
! initialize
      x      =  0.0q0
      sign   =  1.0q0
      factor =  rten
      pflag  =  .false.
      noblnk =  0
      power  =  0
      psign  =  1
      long   =  len(string)

! remove any leading blanks and get the sign of the number
      do z = 1,7
       noblnk = noblnk + 1
       if ( string(noblnk:noblnk) .eq. blank) then
        if (noblnk .gt. 6 ) goto  30
       else
        if (string(noblnk:noblnk) .eq. plus) then
         noblnk = noblnk + 1
        else if (string(noblnk:noblnk) .eq. minus) then
         noblnk = noblnk + 1
         sign =  -1.0q0
        end if
        goto 10
       end if
      enddo

! main number conversion loop
 10   continue
      do i = noblnk,long
       ipoint = i + 1

! if a blank character then we are done
       if ( string(i:i) .eq. blank ) then
        x     = x * sign
        value = x
        return

! if an exponent character, process the whole exponent, and return
       else if (string(i:i) .eq. se .or. &
                string(i:i) .eq. sd .or. &
                string(i:i) .eq. sq .or. &
                string(i:i) .eq. se1 .or. &
                string(i:i) .eq. sd1 .or. &
                string(i:i) .eq. sq1   ) then
        if (x .eq. 0.0 .and. ipoint.eq.2)     x = 1.0q0
        if (sign .eq. -1.0 .and. ipoint.eq.3) x = 1.0q0
        if (string(ipoint:ipoint) .eq. plus) ipoint = ipoint + 1
        if (string(ipoint:ipoint) .eq. minus) then
         ipoint = ipoint + 1
         psign = -1
        end if
        do z = ipoint,long
         if (string(z:z) .eq. blank)  then
          x = sign * x * rten**(power*psign)
          value = x
          return
         else
          j = ichar(string(z:z)) - 48
          if ( (j.lt.0) .or. (j.gt.9) ) goto 30
          power= (power * iten)  + j
         end if
        enddo

! if an ascii number character, process ie
       else if (string(i:i) .ne. decmal) then
        j = ichar(string(i:i)) - 48
        if ( (j.lt.0) .or. (j.gt.9) ) goto 30
        if (.not.(pflag) ) then
         x = (x*rten) + j
        else
         temp   = j
         x      = x + (temp/factor)
         factor = factor * rten
         goto 20
        end if

! must be a decimal point if none of the above
! check that there are not two decimal points!
       else
        if (pflag) goto 30
        pflag = .true.
       end if
 20   continue
      end do

! if we got through the do loop ok, then we must be done
      x     = x * sign
      value = x
      return

! error processing the number
 30   write(6,40) long,string(1:long)
 40   format(' error converting the ',i4,' characters ',/, &
             ' >',a,'< ',/, &
             ' into a real number in function value')
      stop ' error in routine value'
      end function value


      subroutine sproot(t,n,c,zero,mest,m,ier)
c  subroutine sproot finds the zeros of a cubic spline s(x),which is
c  given in its normalized b-spline representation.
c
c  calling sequence:
c     call sproot(t,n,c,zero,mest,m,ier)
c
c  input parameters:
c    t    : real array,length n, containing the knots of s(x).
c    n    : integer, containing the number of knots.  n>=8
c    c    : real array,length n, containing the b-spline coefficients.
c    mest : integer, specifying the dimension of array zero.
c
c  output parameters:
c    zero : real array,lenth mest, containing the zeros of s(x).
c    m    : integer,giving the number of zeros.
c    ier  : error flag:
c      ier = 0: normal return.
c      ier = 1: the number of zeros exceeds mest.
c      ier =10: invalid input data (see restrictions).
c
c  other subroutines required: fpcuro
c
c  restrictions:
c    1) n>= 8.
c    2) t(4) < t(5) < ... < t(n-4) < t(n-3).
c       t(1) <= t(2) <= t(3) <= t(4)
c       t(n-3) <= t(n-2) <= t(n-1) <= t(n)
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c ..
c ..scalar arguments..
      integer n,mest,m,ier
c  ..array arguments..
      real t(n),c(n),zero(mest)
c  ..local scalars..
      integer i,j,j1,l,n4
      real ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2,
     * three,two,t1,t2,t3,t4,t5,zz
      logical z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4
c  ..local array..
      real y(3)
c  ..
c  set some constants
      two = 0.2e+01
      three = 0.3e+01
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      n4 = n-4
      ier = 10
      if(n.lt.8) go to 800
      j = n
      do 10 i=1,3
        if(t(i).gt.t(i+1)) go to 800
        if(t(j).lt.t(j-1)) go to 800
        j = j-1
  10  continue
      do 20 i=4,n4
        if(t(i).ge.t(i+1)) go to 800
  20  continue
c  the problem considered reduces to finding the zeros of the cubic
c  polynomials pl(x) which define the cubic spline in each knot
c  interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on
c  the condition that it belongs to the knot interval.
c  the cubic polynomial pl(x) is determined by computing s(t(l)),
c  s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute
c  s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of
c  splines and their derivatives, the value of s(t(l)) and s'(t(l))
c  is already known from the foregoing knot interval.
      ier = 0
c  evaluate some constants for the first knot interval
      h1 = t(4)-t(3)
      h2 = t(5)-t(4)
      t1 = t(4)-t(2)
      t2 = t(5)-t(3)
      t3 = t(6)-t(4)
      t4 = t(5)-t(2)
      t5 = t(6)-t(3)
c  calculate a0 = s(t(4)) and ah = s'(t(4)).
      c1 = c(1)
      c2 = c(2)
      c3 = c(3)
      c4 = (c2-c1)/t4
      c5 = (c3-c2)/t5
      d4 = (h2*c1+t1*c2)/t4
      d5 = (t3*c2+h1*c3)/t5
      a0 = (h2*d4+h1*d5)/t2
      ah = three*(h2*c4+h1*c5)/t2
      z1 = .true.
      if(ah.lt.0.) z1 = .false.
      nz1 = .not.z1
      m = 0
c  main loop for the different knot intervals.
      do 300 l=4,n4
c  evaluate some constants for the knot interval t(l) <= x <= t(l+1).
        h1 = h2
        h2 = t(l+2)-t(l+1)
        t1 = t2
        t2 = t3
        t3 = t(l+3)-t(l+1)
        t4 = t5
        t5 = t(l+3)-t(l)
c  find a0 = s(t(l)), ah = s'(t(l)), b0 = s(t(l+1)) and bh = s'(t(l+1)).
        c1 = c2
        c2 = c3
        c3 = c(l)
        c4 = c5
        c5 = (c3-c2)/t5
        d4 = (h2*c1+t1*c2)/t4
        d5 = (h1*c3+t3*c2)/t5
        b0 = (h2*d4+h1*d5)/t2
        bh = three*(h2*c4+h1*c5)/t2
c  calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial
c  pl(x) = ql(y) = a0+a1*y+a2*y**2+a3*y**3 ; y = (x-t(l))/(t(l+1)-t(l)).
        a1 = ah*h1
        b1 = bh*h1
        a2 = three*(b0-a0)-b1-two*a1
        a3 = two*(a0-b0)+b1+a1
c  test whether or not pl(x) could have a zero in the range
c  t(l) <= x <= t(l+1).
        z3 = .true.
        if(b1.lt.0.) z3 = .false.
        nz3 = .not.z3
        if(a0*b0.le.0.) go to 100
        z0 = .true.
        if(a0.lt.0.) z0 = .false.
        nz0 = .not.z0
        z2 = .true.
        if(a2.lt.0.) z2 = .false.
        nz2 = .not.z2
        z4 = .true.
        if(3.0*a3+a2.lt.0.) z4 = .false.
        nz4 = .not.z4
        if(.not.((z0.and.(nz1.and.(z3.or.z2.and.nz4).or.nz2.and.
     * z3.and.z4).or.nz0.and.(z1.and.(nz3.or.nz2.and.z4).or.z2.and.
     * nz3.and.nz4))))go to 200
c  find the zeros of ql(y).
 100    call fpcuro(a3,a2,a1,a0,y,j)
        if(j.eq.0) go to 200
c  find which zeros of pl(x) are zeros of s(x).
        do 150 i=1,j
          if(y(i).lt.0. .or. y(i).gt.1.0) go to 150
c  test whether the number of zeros of s(x) exceeds mest.
          if(m.ge.mest) go to 700
          m = m+1
          zero(m) = t(l)+h1*y(i)
 150    continue
 200    a0 = b0
        ah = bh
        z1 = z3
        nz1 = nz3
 300  continue
c  the zeros of s(x) are arranged in increasing order.
      if(m.lt.2) go to 800
      do 400 i=2,m
        j = i
 350    j1 = j-1
        if(j1.eq.0) go to 400
        if(zero(j).ge.zero(j1)) go to 400
        zz = zero(j)
        zero(j) = zero(j1)
        zero(j1) = zz
        j = j1
        go to 350
 400  continue
      j = m
      m = 1
      do 500 i=2,j
c   GH211017
c       if(zero(i).eq.zero(m)) go to 500
        if(abs(zero(i)-zero(m))<epsilon(zero(i))) go to 500
        m = m+1
        zero(m) = zero(i)
 500  continue
      go to 800
 700  ier = 1
 800  return
      end


!##############################################################################
!# ****************************************************************************
!# <name> poisson2d_method0_simple </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstration program how to solve a simple Poisson
!# problem with constant coefficients on a simple domain.
!#
!# The problem is a pure Neumann problem, solved with a direct solver.
!#
!# The reference function is
!#      u = 256 * ( x*(1-x) * y*(1-y) )^2
!# and is realised by separate callback functions in this module.
!# </purpose>
!##############################################################################

module poisson2d_method0_neumann

  use fsystem
  use genoutput
  use storage
  use linearsolver
  use boundary
  use derivatives
  use element
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use filtersupport
  use linearsystemscalar
  use linearsystemblock
  use matrixfilters
  use vectorfilters
  use discretebc
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use scalarpde
  use element
  use ucd
  use pprocerror
  use stdoperators
  use matrixmodification

  use poisson2d_callback

  implicit none

contains

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

!<subroutine>

  subroutine coeff_RHS_NEUMANN_2D (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(in)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(in)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(in)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(in)  :: Dpoints

    ! An array accepting the DOF`s on all elements trial in the trial space.
    ! DIMENSION(#local DOF`s in test space,nelements)
    integer, dimension(:,:), intent(in) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It is usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(inout), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), dimension(:,:,:), intent(out)                      :: Dcoefficients
  !</output>

  !</subroutine>

    !    u(x,y) = 256*(x*(1-x)*y*(1-y))^2
    ! => f(x,y) = ... (a bit complicated)
    Dcoefficients (1,:,:) = &
        - 512.0_DP*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))**2 &
        +2048.0_DP*Dpoints(1,:,:)*(1-Dpoints(1,:,:))*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))**2 &
        - 512.0_DP*Dpoints(1,:,:)**2*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))**2 &
        - 512.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))**2*(1-Dpoints(2,:,:))**2 &
        +2048.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)*(1-Dpoints(2,:,:)) &
        - 512.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)**2

  end subroutine

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

!<subroutine>

  subroutine getReference_NEUMANN_2D (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! This subroutine is called during the calculation of errors. It has to compute
  ! the (analytical) values of a function in a couple of points on a couple
  ! of elements. These values are compared to those of a computed FE function
  ! and used to calculate an error.
  !
  ! The routine accepts a set of elements and a set of points on these
  ! elements (cubature points) in in real coordinates.
  ! According to the terms in the linear form, the routine has to compute
  ! simultaneously for all these points.
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in)                      :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in)              :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out)                      :: Dvalues
!</output>

!</subroutine>

    select case (cderivative)
    case (DER_FUNC)
      ! u(x,y) = 256*(x*(1-x)*y*(1-y))^2 - c
      ! with c = int( 256*(x*(1-x)*y*(1-y))^2 ) / |Omega| = 64/225
      ! due to the mean value constraint.
      Dvalues (:,:) = 256.0_DP * ( Dpoints(1,:,:)*(1.0_DP-Dpoints(1,:,:)) * &
                                  Dpoints(2,:,:)*(1.0_DP-Dpoints(2,:,:)) )**2 &
                      - 64.0_DP/225.0_DP

    case (DER_DERIV_X)
      !    u(x,y)   = 256*(x*(1-x)*y*(1-y))^2 - c
      ! => u_x(x,y) = ... (a bit complicated)
      Dvalues (:,:) = &
          512.0_DP*Dpoints(1,:,:)*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))**2 &
          -512.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))**2

    case (DER_DERIV_Y)
      !    u(x,y)   = 256*(x*(1-x)*y*(1-y))^2 - c
      ! => u_y(x,y) = ... (a bit complicated)
      Dvalues (:,:) = &
          512.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)*(1-Dpoints(2,:,:))**2 &
          -512.0_DP*Dpoints(1,:,:)**2*(1-Dpoints(1,:,:))**2*Dpoints(2,:,:)**2*(1-Dpoints(2,:,:))

    case default
      ! Unknown. Set the result to 0.0.
      Dvalues = 0.0_DP
    end select

  end subroutine

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

!<subroutine>

  subroutine poisson2d_0_neumann

!<description>
  ! This is an all-in-one poisson solver for directly solving a Poisson
  ! problem without making use of special features like collections
  ! and so on. The routine performs the following tasks:
  !
  ! 1.) Read in parametrisation
  ! 2.) Read in triangulation
  ! 3.) Set up RHS
  ! 4.) Set up matrix
  ! 5.) Create solver structure
  ! 6.) Solve the problem
  ! 7.) Write solution to VTK file
  ! 8.) Release all variables, finish
!</description>

!</subroutine>

    ! Definitions of variables.
    !
    ! We need a couple of variables for this problem. Let us see...
    !
    ! An object for saving the domain:
    type(t_boundary) :: rboundary

    ! An object for saving the triangulation on the domain
    type(t_triangulation) :: rtriangulation

    ! Path to the mesh
    character(len=SYS_STRLEN) :: spredir

    ! An object specifying the discretisation.
    ! This contains also information about trial/test functions,...
    type(t_blockDiscretisation) :: rdiscretisation

    ! Cubature info structure which encapsules the cubature formula
    type(t_scalarCubatureInfo) :: rcubatureInfo

    ! A matrix, a RHS vector, a solution vector and a temporary vector.
    ! The RHS vector accepts the RHS of the problem, the solution vector
    ! accepts the solution. All are block vectors with only one block.
    type(t_matrixBlock) :: rmatSystem
    type(t_vectorBlock) :: rvecSol,rvecRhs,rvecTmp
    type(t_matrixScalar) :: rmassMatrixLumped

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode
    ! NLMAX receives the level where we want to solve.
    integer :: NLMAX

    ! Error indicator during initialisation of the solver
    integer :: ierror

    ! Error of FE function to reference function
    real(DP) :: derror

    ! Output block for UCD output to VTK file
    type(t_ucdExport) :: rexport
    character(len=SYS_STRLEN) :: sucddir

    ! Ok, let us start.
    !
    ! We want to solve our Poisson problem on level...
    NLMAX = 7

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Read the domain, read the mesh, refine
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Get the path $PREDIR from the environment, where to read .prm/.tri files
    ! from. If that does not exist, write to the directory "./pre".
    if (.not. sys_getenv_string("PREDIR", spredir)) spredir = "./pre"

    ! At first, read in the parametrisation of the boundary and save
    ! it to rboundary.
    call boundary_read_prm(rboundary, trim(spredir)//"/QUAD.prm")

    ! Now read in the basic triangulation.
    call tria_readTriFile2D (rtriangulation, trim(spredir)//"/QUAD.tri", rboundary)

    ! Refine it.
    call tria_quickRefine2LevelOrdering (NLMAX-1,rtriangulation,rboundary)

    ! And create information about adjacencies and everything one needs from
    ! a triangulation.
    call tria_initStandardMeshFromRaw (rtriangulation,rboundary)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Set up a discretisation structure which tells the code which
    ! finite element to use
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Now we can start to initialise the discretisation. At first, set up
    ! a block discretisation structure that specifies the blocks in the
    ! solution vector. In this simple problem, we only have one block.
    call spdiscr_initBlockDiscr (rdiscretisation,1,&
                                 rtriangulation, rboundary)

    ! rdiscretisation%Rdiscretisations is a list of scalar discretisation
    ! structures for every component of the solution vector.
    ! Initialise the first element of the list to specify the element
    ! for this solution component:
    call spdiscr_initDiscr_simple (rdiscretisation%RspatialDiscr(1), &
                                   EL_Q1,rtriangulation, rboundary)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Set up an cubature info structure to tell the code which cubature
    ! formula to use
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Create an assembly information structure which tells the code
    ! the cubature formula to use.
    call spdiscr_createDefCubStructure(&
        rdiscretisation%RspatialDiscr(1),rcubatureInfo,CUB_GEN_AUTO_G4)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Create a 1x1 block matrix with the operator
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Now as the discretisation is set up, we can start to generate
    ! the structure of the system matrix which is to solve.
    ! At first, create a basic 1x1 block matrix based on the discretisation.
    call lsysbl_createMatrix (rdiscretisation,rmatSystem)

    ! We create a scalar matrix, based on the discretisation structure
    ! for our one and only solution component.
    call bilf_createMatrixStructure (rmatSystem, 1, 1, LSYSSC_MATRIX9)

    ! And now to the entries of the matrix.
    ! We do a quick approach here applying the method from the stdoperators
    ! module.
    call stdop_assembleLaplaceMatrix(&
        rmatSystem%RmatrixBlock(1,1), .true., 1.0_DP, rcubatureInfo)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Create RHS and solution vectors
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Next step: Create a RHS vector, a solution vector and a temporary
    ! vector. All are filled with zero.
    call lsysbl_createVector (rdiscretisation,rvecRhs,.true.)
    call lsysbl_createVector (rdiscretisation,rvecSol,.true.)
    call lsysbl_createVector (rdiscretisation,rvecTmp,.true.)

    ! Now assemble the right-hand-side vector
    call linf_buildSimpleVector(rvecRhs%RvectorBlock(1), rcubatureInfo, &
        coeff_RHS_NEUMANN_2D)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Assembly of matrices/vectors finished
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Discretise the boundary conditions and apply them to the matrix/RHS/sol.
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! There are no Dirichlet boundary conditions, this is a pure
    ! Neumann problem. To successfully process this type of problem,
    ! we modify the system as well as the RHS using a lumped mass matrix
    ! approach. Note that this does only works for Lagrangian based
    ! finite elements (i.e., DOFs corresponds to values in vertices)

    ! Step 1: Generate a diagonal lumped mass matrix based on the structure of the
    !         Laplace matrix
    call lsyssc_duplicateMatrix (rmatSystem%RmatrixBlock(1,1),rmassMatrixLumped,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    call lsyssc_clearMatrix (rmassMatrixLumped)

    call stdop_assembleSimpleMatrix (rmassMatrixLumped,DER_FUNC,DER_FUNC,1.0_DP)
    call lsyssc_lumpMatrix (rmassMatrixLumped,LSYSSC_LUMP_DIAG,.true.)

    ! Step 2: Filter the RHS to fulfil "int(f)=0".
    ! This means, subtract the integral mean value: f:=f-int(f)/|Omega|
    call vecfil_rhsL1To0ByLmass (rvecRhs%RvectorBlock(1),rmassMatrixLumped)

    ! Step 3: Modify the matrix/rhs and impose the mean value condition.
    !
    ! We impose the diagonal of a lumped mass matrix as first row into the
    ! matrix. Furthermore, we modify the first entry of the RHS to be =0.
    ! This imposes the condition "int(u)=0" into the system.
    !
    ! a) Modification of the RHS, impose a zero at f_1.
    call vecfil_oneEntryZero (rvecRhs,1,1)

    ! b) Impose the diagonal of the lumped mass matrix as first row
    !    of the system matrix. Note that this changes the structure
    !    of the matrix! The first row is full afterwards.
    call mmod_replaceLineByLumpedMass (rmatSystem%RmatrixBlock(1,1),1,rmassMatrixLumped)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Set up a linear solver
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Create an UMFPACK direct solver.
    call linsol_initUmfpack4 (p_rsolverNode)

    ! Attach the system matrix to the solver.
    call linsol_setMatrix(p_rsolverNode,rmatSystem)

    ! Initialise structure/data of the solver. This allows the
    ! solver to allocate memory / perform some precalculation
    ! to the problem.
    call linsol_initStructure (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line("Matrix structure invalid!",OU_CLASS_ERROR)
      call sys_halt()
    end if

    call linsol_initData (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line("Matrix singular!",OU_CLASS_ERROR)
      call sys_halt()
    end if

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Solve the system
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! Finally solve the system. As we want to solve Ax=b with
    ! b being the real RHS and x being the real solution vector,
    ! we use linsol_solveAdaptively. If b is a defect
    ! RHS and x a defect update to be added to a solution vector,
    ! we would have to use linsol_precondDefect instead.
    call linsol_solveAdaptively (p_rsolverNode,rvecSol,rvecRhs,rvecTmp)

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Postprocessing of the solution
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! That is it, rvecSol now contains our solution. We can now
    ! start the postprocessing.
    !
    ! Get the path for writing postprocessing files from the environment variable
    ! $UCDDIR. If that does not exist, write to the directory "./gmv".
    if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = "./gmv"

    ! Start UCD export to VTK file:
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       trim(sucddir)//"/u2d_0_neumann.vtk")

    ! Add the solution to the UCD exporter
    call ucd_addVectorByVertex (rexport, "sol", UCD_VAR_STANDARD, &
        rvecSol%RvectorBlock(1))

    ! Write the file to disc, that is it.
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! Calculate the error to the reference function.
    call pperr_scalar (PPERR_L2ERROR,derror,rvecSol%RvectorBlock(1),&
                       getReference_NEUMANN_2D, rcubatureInfo=rcubatureInfo)
    call output_line ("L2-error: " // sys_sdEL(derror,10) )

    call pperr_scalar (PPERR_H1ERROR,derror,rvecSol%RvectorBlock(1),&
                       getReference_NEUMANN_2D, rcubatureInfo=rcubatureInfo)
    call output_line ("H1-error: " // sys_sdEL(derror,10) )

    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    ! Clean up
    ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

    ! We are finished - but not completely!
    ! Now, clean up so that all the memory is available again.
    !
    ! Release solver data and structure
    call linsol_doneData (p_rsolverNode)
    call linsol_doneStructure (p_rsolverNode)

    ! Release the solver node and all subnodes attached to it (if at all):
    call linsol_releaseSolver (p_rsolverNode)

    ! Release the block matrix/vectors
    call lsysbl_releaseVector (rvecTmp)
    call lsysbl_releaseVector (rvecSol)
    call lsysbl_releaseVector (rvecRhs)
    call lsysbl_releaseMatrix (rmatSystem)
    call lsyssc_releaseMatrix (rmassMatrixLumped)

    ! Release the cubature info structure.
    call spdiscr_releaseCubStructure(rcubatureInfo)

    ! Release the discretisation structure and all spatial discretisation
    ! structures in it.
    call spdiscr_releaseBlockDiscr(rdiscretisation)

    ! Release the triangulation.
    call tria_done (rtriangulation)

    ! Finally release the domain, that is it.
    call boundary_release (rboundary)

  end subroutine

end module


!http://software.intel.com/en-us/articles/intel-math-kernel-library-intel-mkl-intel-mkl-100-threading/#3
include 'mkl_vsl.fi'
module numz
! module defines the basic real type and pi
          integer, parameter:: b8 = selected_real_kind(14)
          integer, parameter:: i8 = selected_int_kind(15)
          real(b8), parameter :: pi = 3.141592653589793239_b8
      end module
      program testinvert
      use numz
      USE MKL_VSL_TYPE
      USE MKL_VSL
      implicit none
      real(b8), allocatable,target :: tarf(:,:,:)
      real(b8), pointer :: twod(:,:)
!     real(b8), pointer :: one(:)
      real(b8), allocatable,target :: bs(:,:)
      integer, allocatable,target :: IPIVS(:,:)
      integer, allocatable :: infos(:)
      real(b8),allocatable :: cnt1(:),cnt2(:)
      real(b8) stime,etime
      integer i,j,k,kmax
      integer omp_get_max_threads,OMP_GET_THREAD_NUM,maxthreads
      integer msize,nrays
      integer N, NRHS,LDA, LDB
      integer(i8) asize
      TYPE (VSL_STREAM_STATE), allocatable :: stream(:)
      integer , allocatable :: seed(:),errcode(:)
      integer brng,method
      real(b8) a,sigma
! set up random number generators for each thread
      maxthreads=omp_get_max_threads()
      allocate(stream(maxthreads))
      allocate(seed(maxthreads))
      allocate(errcode(maxthreads))
      brng=VSL_BRNG_MCG31
      method=0
      a=1.0_b8
      sigma=1.0_b8
!$OMP PARALLEL DO
      do i=1,maxthreads
        seed(i)=i+i**2
        errcode(i)=vslnewstream(stream(i), brng,  seed(i) )
!        write(*,*)i,errcode(i)
      enddo
      msize=1000
      nrays=4
      kmax=1
      read(*,*)msize,nrays,kmax
      nrhs=1
      n=msize
      lda=msize
      ldb=msize
      allocate(tarf(msize,msize,nrays))
      allocate(bs(msize,nrays))
      allocate(IPIVS(msize,nrays))
      allocate(infos(nrays))
      allocate(cnt1(nrays))
      allocate(cnt2(nrays))
!      one=>tarf(:,1,1)
! this is very bad practice
!      do i=1,(msize*msize*nrays)
!      	one(i)=i
!      enddo
!      write(*,*)size(one)
      write(*,*)"matrix size=",msize
      write(*,*)"copies=",nrays
      asize=size(tarf,kind=i8)
      write(*,'(" bytes=",i15," gbytes=",f10.3)')asize*8_i8,real(asize,b8)*8.0_b8/1073741824.0_b8
      do k=1,kmax
      write(*,*)"generating data for run",k," of ",kmax
      call my_clock(stime)
!$OMP PARALLEL DO PRIVATE(twod)
      do i=1,nrays
        twod=>tarf(:,:,i)
        j=omp_get_thread_num()+1
        errcode(j)=vdrnggaussian( method, stream(j), msize*msize, twod, a,sigma)
!        write(*,*)"sub array ",i,j,errcode(j),twod(1,1)
      enddo
!      call RANDOM_NUMBER(bs)
!      bs=1.0_b8
      call my_clock(etime)
      write(*,'(" generating time=",f12.3," threads=",i3)'),real(etime-stime,b8),maxthreads
      stop

!      write(*,*)tarf
      write(*,*)"starting inverts"

      call my_clock(stime)

!$OMP PARALLEL DO PRIVATE(twod)
      do i=1,nrays
        twod=>tarf(:,:,i)
!        write(*,*)twod
        call my_clock(cnt1(i))
        CALL DGESV( N, NRHS, twod, LDA, IPIVs(:,i), Bs(:,i), LDB, INFOs(i) )
        call my_clock(cnt2(i))
        write(*,'(i5,i5,3(f12.3))')i,infos(i),cnt2(i),cnt1(i),real(cnt2(i)-cnt1(i),b8)
      enddo
      call my_clock(etime)
      write(*,'(" invert time=",f12.3)'),real(etime-stime,b8)
      enddo
      end program
!
      subroutine my_clock(x)
      use numz
      real(b8) x
      integer vals(8)
      call date_and_time(values=vals)
      x=real(vals(8),b8)/1000.0_b8
      x=x+real(vals(7),b8)
      x=x+real(vals(6),b8)*60
      x=x+real(vals(5),b8)*3600
      end subroutine


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief apply 7point-star matrix multiply [as]:=[M]x[s]
!>    @param[in] N_I lengths of I dimension of local matrix [M]
!>    @param[in] N_J lengths of J dimension of local matrix [M]
!>    @param[in] N_K lengths of K dimension of local matrix [M]
!>    @param[in] s vector [s]
!>    @param[out] as vector [as]
!>    @param[out] t temporary vector, used for computation
!>    @param[in] MA 1. diagonal of the system matrix [M]
!>    @param[in] MB 2. diagonal of the system matrix [M]
!>    @param[in] MC 3. diagonal of the system matrix [M]
!>    @param[in] MD 4. (main) diagonal of the system matrix [M]
!>    @param[in] ME 5. diagonal of the system matrix [M]
!>    @param[in] MF 6. diagonal of the system matrix [M]
!>    @param[in] MG 7. diagonal of the system matrix [M]
!>    @details
!>    OpenMP parallelised, general version - no special blocking\n
!>    apply 7point-star matrix multiply\n
!>    compute [as]:=[M]x[s], [s],[as],[M] given in 3-D-structure\n
!>    Data-Cube :\n
!> @image html cube.png
!       k     * * * *
!     /     *     * *
!    0 -j * * * *   *
!    |    *     *   *
!    i    *     * *
!         * * * *
      SUBROUTINE ssor_mvp_single(n_i,n_j,n_k,s,as,t,ma,mb,mc,md,me,mf, &
          mg)
        use mod_OMP_TOOLS
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'
        INTEGER n_i, n_j, n_k
!
        DOUBLE PRECISION s(n_i,n_j,n_k), as(n_i,n_j,n_k)
        DOUBLE PRECISION ma(n_i,n_j,n_k), mb(n_i,n_j,n_k), &
          mc(n_i,n_j,n_k)
        DOUBLE PRECISION md(n_i,n_j,n_k), me(n_i,n_j,n_k), &
          mf(n_i,n_j,n_k)
        DOUBLE PRECISION mg(n_i,n_j,n_k)
!     t : tmp. vector
        DOUBLE PRECISION t(n_i,n_j,n_k)
!     loop variable
        INTEGER i, j, k
!
        INTEGER panz, ppos
        EXTERNAL panz, ppos
!     THREAD-stuff
        ! INTEGER tpos, tanz
!
        INTEGER ijk

!       compute boundary size
        ijk = n_i*n_j*n_k

! #####################################################################
! Main
! given : A=L+D+U

! t:=(D+U)^(-1)*s

!$OMP master
        CALL dcopy(ijk,s,1,t,1)

        DO k = n_k, 1, -1
          DO j = n_j, 1, -1
            DO i = n_i, 1, -1
              IF (i<n_i) t(i,j,k) = t(i,j,k) - me(i,j,k)*t(i+1,j,k)
              IF (j<n_j) t(i,j,k) = t(i,j,k) - mf(i,j,k)*t(i,j+1,k)
              IF (k<n_k) t(i,j,k) = t(i,j,k) - mg(i,j,k)*t(i,j,k+1)
!AW         ugly hack ...
              IF (md(i,j,k)/=0.0D0) THEN
                t(i,j,k) = t(i,j,k)/md(i,j,k)
              END IF
            END DO
          END DO
        END DO

!CC t2 : tot, t3 = as
! t2 =(s - D*t)
! t3 =(D+L)^(-1) * t2

        CALL dcopy(ijk,s,1,as,1)

!AW   call daxpy(ijk,-1.0d0,t,1,as,1)
        DO k = 1, n_k
          DO j = 1, n_j
            DO i = 1, n_i
              as(i,j,k) = as(i,j,k) - t(i,j,k)*md(i,j,k)
            END DO
          END DO
        END DO

        DO k = 1, n_k
          DO j = 1, n_j
            DO i = 1, n_i
              IF (i>1) as(i,j,k) = as(i,j,k) - mc(i,j,k)*as(i-1,j,k)
              IF (j>1) as(i,j,k) = as(i,j,k) - mb(i,j,k)*as(i,j-1,k)
              IF (k>1) as(i,j,k) = as(i,j,k) - ma(i,j,k)*as(i,j,k-1)
!AW         ugly hack ...
              IF (md(i,j,k)/=0.0D0) THEN
                as(i,j,k) = as(i,j,k)/md(i,j,k)
              END IF
            END DO
          END DO
        END DO

!CC t3 = as, t4 : tot
! t4 = t + t3
! A^T*s = D * t4

        CALL daxpy(ijk,1.0D0,t,1,as,1)

        DO k = 1, n_k
          DO j = 1, n_j
            DO i = 1, n_i
              as(i,j,k) = as(i,j,k)*md(i,j,k)
            END DO
          END DO
        END DO
!$OMP end master
!$OMP barrier

        RETURN
      END


module newtonraphson

use iso_c_binding

implicit none

private :: isInteger
public :: nr_sqrt, int_2x, int_sq, isEven

contains

real(c_double) function randn()
  integer :: n
  integer, allocatable :: seed(:)
  real(c_double) :: r

  ! call random_seed(size = seedsize)
  call random_seed(size = n)
  write (*,*) n
  allocate(seed(n))
  call random_seed(get=seed)
  write (*, *) seed

  call random_number(r)
  write (*,*) r
  randn = r
end function

real(c_double) function nr_sqrt(n, x0, iterations, printIts) bind(c, name='nr_sqrt')
  real(c_double), intent(in) :: n, x0
  integer(c_int), intent(in) :: iterations
  logical(c_bool), intent(in) :: printIts
  integer :: i
  real(c_double) :: xm1

  do i = 1, iterations
    if (i == 1) then
      xm1 = x0
    endif

    ! if integer, use integer algorithm
    if (isInteger(xm1)) then
      nr_sqrt = xm1 - (int_sq(int(xm1))-n)/(int_2x(int(xm1)))
    else
      nr_sqrt = xm1 - (xm1**2-n)/(2*xm1)
    end if

    if (printIts) then
      print *, xm1
    end if

    xm1 = nr_sqrt
  end do

  return
end function

integer(c_int) function int_2x(n) bind(c, name='int_2x')
  integer(c_int), value, intent(in) :: n
  int_2x = ishft(n, 1)
end function

recursive integer(c_int) function int_sq(n) bind(c, name='int_sq') result(sq)
  integer(c_int), value, intent(in) :: n
  integer :: x

  if (n.eq.0) then
    sq = 0
  else
    x = ishft(n, -1)
    if (isEven(n)) then
      sq = ishft(int_sq(x),2)
    else
      sq = ishft(int_sq(x),2) + ishft(x,2) + 1
    end if
  end if
end function

logical function isEven(n)
  integer, intent(in) :: n
  isEven = mod(n,2) == 0
end function

logical function isInteger(n)
  real(c_double), intent(in) :: n
  isInteger = mod(n,1.0) == 0
end function

end module


!*==claqge.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLAQGE + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
!                          EQUED )
!
!       .. Scalar Arguments ..
!       CHARACTER          EQUED
!       INTEGER            LDA, M, N
!       REAL               AMAX, COLCND, ROWCND
!       ..
!       .. Array Arguments ..
!       REAL               C( * ), R( * )
!       COMPLEX            A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLAQGE equilibrates a general M by N matrix A using the row and
!> column scaling factors in the vectors R and C.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M by N matrix A.
!>          On exit, the equilibrated matrix.  See EQUED for the form of
!>          the equilibrated matrix.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(M,1).
!> \endverbatim
!>
!> \param[in] R
!> \verbatim
!>          R is REAL array, dimension (M)
!>          The row scale factors for A.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL array, dimension (N)
!>          The column scale factors for A.
!> \endverbatim
!>
!> \param[in] ROWCND
!> \verbatim
!>          ROWCND is REAL
!>          Ratio of the smallest R(i) to the largest R(i).
!> \endverbatim
!>
!> \param[in] COLCND
!> \verbatim
!>          COLCND is REAL
!>          Ratio of the smallest C(i) to the largest C(i).
!> \endverbatim
!>
!> \param[in] AMAX
!> \verbatim
!>          AMAX is REAL
!>          Absolute value of largest matrix entry.
!> \endverbatim
!>
!> \param[out] EQUED
!> \verbatim
!>          EQUED is CHARACTER*1
!>          Specifies the form of equilibration that was done.
!>          = 'N':  No equilibration
!>          = 'R':  Row equilibration, i.e., A has been premultiplied by
!>                  diag(R).
!>          = 'C':  Column equilibration, i.e., A has been postmultiplied
!>                  by diag(C).
!>          = 'B':  Both row and column equilibration, i.e., A has been
!>                  replaced by diag(R) * A * diag(C).
!> \endverbatim
!
!> \par Internal Parameters:
!  =========================
!>
!> \verbatim
!>  THRESH is a threshold value used to decide if row or column scaling
!>  should be done based on the ratio of the row or column scaling
!>  factors.  If ROWCND < THRESH, row scaling is done, and if
!>  COLCND < THRESH, column scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if row scaling
!>  should be done based on the absolute size of the largest matrix
!>  element.  If AMAX > LARGE or AMAX  \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGEauxiliary
!
!  =====================================================================
      SUBROUTINE CLAQGE(M,N,A,Lda,R,C,Rowcnd,Colcnd,Amax,Equed)
      IMPLICIT NONE
!*--CLAQGE146
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Equed
      INTEGER Lda , M , N
      REAL Amax , Colcnd , Rowcnd
!     ..
!     .. Array Arguments ..
      REAL C(*) , R(*)
      COMPLEX A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , THRESH
      PARAMETER (ONE=1.0E+0,THRESH=0.1E+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , j
      REAL cj , large , small
!     ..
!     .. External Functions ..
      REAL SLAMCH
      EXTERNAL SLAMCH
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF ( M<=0 .OR. N<=0 ) THEN
         Equed = 'N'
         RETURN
      ENDIF
!
!     Initialize LARGE and SMALL.
!
      small = SLAMCH('Safe minimum')/SLAMCH('Precision')
      large = ONE/small
!
      IF ( Rowcnd>=THRESH .AND. Amax>=small .AND. Amax<=large ) THEN
!
!        No row scaling
!
         IF ( Colcnd>=THRESH ) THEN
!
!           No column scaling
!
            Equed = 'N'
         ELSE
!
!           Column scaling
!
            DO j = 1 , N
               cj = C(j)
               DO i = 1 , M
                  A(i,j) = cj*A(i,j)
               ENDDO
            ENDDO
            Equed = 'C'
         ENDIF
      ELSEIF ( Colcnd>=THRESH ) THEN
!
!        Row scaling, no column scaling
!
         DO j = 1 , N
            DO i = 1 , M
               A(i,j) = R(i)*A(i,j)
            ENDDO
         ENDDO
         Equed = 'R'
      ELSE
!
!        Row and column scaling
!
         DO j = 1 , N
            cj = C(j)
            DO i = 1 , M
               A(i,j) = cj*R(i)*A(i,j)
            ENDDO
         ENDDO
         Equed = 'B'
      ENDIF
!
!
!     End of CLAQGE
!
      END SUBROUTINE CLAQGE


!Module that lets us compare the mode evolution to the slow-roll expectation for
!sum-separable potentials, using the results of Battefeld-Easther astro-ph/0610296
module modpk_deltaN
  use modpkparams, only : dp, vparams
  use modpk_observables, only : power_spectra
  use internals, only : pi
  use potential, only : pot, dVdphi, d2Vdphi2, d3Vdphi3
  use modpk_errorhandling, only : raise, assert
  implicit none

  !The horizon crossing approximation
  logical :: HC_approx=.false.

  !Tolerance value for checking division by zero
  real(dp), private, parameter :: div_tol=1e-20

  !Zero checking for regularization
  interface check_div_zero
  	module procedure check_div_zero_real
  	module procedure check_div_zero_array
  end interface

  contains

    !Evalutes adiabatic power spectrum under SR approximation at field positions
    !phi_end, given that the mode of interest crossed the horizon at phi_pivot
    !Assumes a massless, uncorrelated mode subhorizon
    function PR_SR(phi_pivot,phi_end, spectrum) result(PR)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) ::PR
      real(dp), dimension(size(phi_pivot)) :: dN
      real(dp) :: H_piv, V_piv, P_dphi
      real(dp), dimension(size(phi_pivot)) :: eps_i, u_i
      type(power_spectra), intent(in), optional :: spectrum
      integer :: ii, jj

      V_piv = pot(phi_pivot)
      H_piv = sqrt(V_piv/3.0e0_dp)
      dN = dNdphi_SR(phi_pivot,phi_end)

      P_dphi = (H_piv/2.0e0_dp/pi)**2

      PR = sum(dN*dN)*P_dphi

      if (present(spectrum)) then
        PR=0e0_dp
        do ii=1,size(dN); do jj=1,size(dN)
          PR = PR+ &
            dN(ii)*dN(jj)*spectrum%phi_ij(ii,jj)
        end do; end do
      end if

      call assert%check(.not. isnan(PR), __FILE__, __LINE__)

    end function PR_SR

    function r_SR(phi_pivot,phi_end, spectrum) result(r)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) :: r
      real(dp), dimension(size(phi_pivot)) :: dN
      type(power_spectra), intent(in), optional :: spectrum
      real(dp) :: P_tens, P_scal, H, V

      integer :: ii, jj

      dN = dNdphi_SR(phi_pivot,phi_end)

      r = 8.0e0_dp/sum(dN*dN)

      if (present(spectrum)) then
        V = pot(phi_pivot)
        H = sqrt(V/3.0e0_dp)
        P_tens = 8.0e0_dp*(H/2.0e0_dp/pi)**2

        P_scal=0e0_dp
        do ii=1,size(dN); do jj=1,size(dN)
          P_scal = P_scal + &
            dN(ii)*dN(jj)*spectrum%phi_ij(ii,jj)
        end do; end do

        r = P_tens/P_scal

      end if

      call assert%check(.not. isnan(r), __FILE__, __LINE__)

    end function r_SR

    function nt_SR(phi_pivot) result(nt)
      real(dp), dimension(:), intent(in) :: phi_pivot
      real(dp) :: nt, eps(size(phi_pivot))

      eps = eps_SR(phi_pivot)

      !nt = -2.0e0_dp*sum(eps)
      nt = -2.0e0_dp*sum(eps)/(1.0e0_dp - sum(eps))

      call assert%check(.not. isnan(nt), __FILE__, __LINE__)

    end function nt_SR

    !Assumes independent, GRFs at horizon exit
    function fNL_SR(phi_pivot,phi_end) result(fnl)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) :: fnl
      real(dp), dimension(size(phi_pivot)) :: dN
      real(dp), dimension(size(phi_pivot),size(phi_pivot)) :: d2N
      integer :: ii, jj

      dN = dNdphi_SR(phi_pivot,phi_end)
      d2N = d2Ndphi2_SR(phi_pivot,phi_end)

      fnl=0e0_dp
      do ii=1,size(dN); do jj=1,size(dN)
        fnl = fnl + dN(ii)*dN(jj)*d2N(ii,jj)
      end do; end do
      fnl = fnl*(-5.0e0_dp/6.0e0_dp)/(sum(dN*dN))**2

      call assert%check(.not. isnan(fnl), __FILE__, __LINE__)

    end function fNL_SR

    !Assumes independent, GRFs at horizon exit
    !From Eq 41 in astro-ph/0611075
    function tauNL_SR(phi_pivot,phi_end) result(taunl)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) :: taunl
      real(dp), dimension(size(phi_pivot)) :: dN
      real(dp), dimension(size(phi_pivot),size(phi_pivot)) :: d2N
      integer :: aa, bb, cc

      dN = dNdphi_SR(phi_pivot,phi_end)
      d2N = d2Ndphi2_SR(phi_pivot,phi_end)

      taunl=0e0_dp
      do aa=1,size(dN); do bb=1,size(dN); do cc=1,size(dN)
        taunl = taunl + d2N(aa,bb)*d2N(aa,cc)*dN(bb)*dN(cc)
      end do; end do; end do
      taunl = taunl*(1.0e0_dp)/(sum(dN*dN))**3

      call assert%check(.not. isnan(taunl), __FILE__, __LINE__)

    end function tauNL_SR

    function ns_SR(phi_pivot,phi_end) result(ns)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) :: ns, eps_piv, V
      real(dp), dimension(size(phi_pivot),size(phi_pivot)) :: d2V
      real(dp), dimension(size(phi_pivot)) :: dV, dN
      integer :: ii, jj
      real(dp), dimension(size(phi_pivot)) :: eps_i, eta_i, u_i

      d2V = d2Vdphi2(phi_pivot)
      dN = dNdphi_SR(phi_pivot,phi_end)
      eps_piv = sum(eps_SR(phi_pivot))
      V = pot(phi_pivot)

      ns = 1.0e0_dp &
        - 2.0e0_dp*eps_piv &
        - (2.0e0_dp/sum(dN*dN))

      do ii=1,size(phi_pivot); do jj=1,size(phi_pivot)
        ns = ns +&
          2.0e0_dp*d2V(ii,jj)*dN(ii)*dN(jj)/V/sum(dN*dN)
      end do; end do

      call assert%check(.not. isnan(ns), __FILE__, __LINE__)

    end function ns_SR

    !Running of ns
    !Formula as in Eq 6.14 1203.3792
    function alpha_s_SR(phi_pivot,phi_end) result(alpha_s)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp) :: alpha_s

      real(dp), dimension(size(phi_pivot)) :: V_i, Z_i, u_i
      real(dp) :: V, eps_piv
      real(dp), dimension(size(phi_pivot)) :: eps_i_piv, eta_i_piv, &
        xi_i_piv
      real(dp) :: sum_ui_over_epsi
      real(dp) :: term1, term2, term3, term4, term5, term6

      V = pot(phi_pivot)
      eps_i_piv = eps_SR(phi_pivot)
      eps_piv = sum(eps_i_piv)
      xi_i_piv = xi_SR(phi_pivot)
      eta_i_piv = eta_SR(phi_pivot)

      V_i = V_i_sum_sep(phi_pivot)
      Z_i = Z_i_BE(phi_end)
      u_i = (V_i + Z_i)/V

      !Check for division by zero
      call check_div_zero(eps_i_piv)

      sum_ui_over_epsi = sum(u_i**2/eps_i_piv)

      term1 = -8.0e0_dp * eps_piv**2
      term2 = 4.0e0_dp * sum(eps_i_piv*eta_i_piv)

      term3 = (-16.0e0_dp/sum_ui_over_epsi**2)*&
        (1.0e0_dp - sum(eta_i_piv*u_i**2/2.0e0_dp/eps_i_piv))**2

      term4 = (-8.0e0_dp/sum_ui_over_epsi)*&
        sum(eta_i_piv*u_i*(1.0e0_dp - &
          eta_i_piv*u_i**2/2.0e0_dp/eps_i_piv))

      term5 = (4.0e0_dp*eps_piv/sum_ui_over_epsi)*&
        sum(eta_i_piv*u_i**2/eps_i_piv)

      term6 = (-2.0e0_dp/sum_ui_over_epsi)*&
        sum(xi_i_piv*u_i**2/eps_i_piv)

      alpha_s = term1 + term2 + term3 + term4 + term5 + term6

      call assert%check(.not. isnan(alpha_s), __FILE__, __LINE__)

    end function alpha_s_SR

    !Deriv of N wrt phi on horiz cross surface
    !Battefeld-Easther eq 29
    function dNdphi_SR(phi_pivot,phi_end)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp), dimension(size(phi_pivot)) :: dNdphi_SR
      real(dp), dimension(size(phi_pivot)) :: eps, V_i, Z_i
      real(dp) :: V

      integer :: ii

      eps = eps_SR(phi_pivot)
      V_i = V_i_sum_sep(phi_pivot)
      Z_i = Z_i_BE(phi_end)
      V = pot(phi_pivot)

      !Check for division by zero
      call check_div_zero(eps)

      dNdphi_SR = ((1.0e0_dp/sqrt(2.0e0_dp*eps))/V)*(V_i + Z_i)

      call assert%check(.not. any(isnan(dNdphi_SR)), __FILE__, __LINE__)

    end function dNdphi_SR

    !2nd Deriv of N wrt phi on horiz cross surface
    !Battefeld-Easther eq 32
    function d2Ndphi2_SR(phi_pivot,phi_end)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp), dimension(size(phi_pivot),size(phi_pivot)) :: d2Ndphi2_SR
      real(dp), dimension(size(phi_end),size(phi_end)) :: delta

      real(dp), dimension(size(phi_end)) :: eta_piv, eps_piv, V_i_piv, Z_i
      real(dp) :: V_piv
      real(dp), dimension(size(phi_end),size(phi_end)) :: dZ_ij

      integer :: ll, kk

      eta_piv = eta_SR(phi_pivot)
      eps_piv = eps_SR(phi_pivot)
      V_i_piv = V_i_sum_sep(phi_pivot)
      Z_i = Z_i_BE(phi_end)
      V_piv = pot(phi_pivot)
      dZ_ij = dZdphi_ij_BE(phi_pivot,phi_end)

      !Identity matrix
      delta=0e0_dp
      do ll=1, size(phi_end)
        delta(ll,ll) = 1.0e0_dp
      end do

      !Check for division by zero
      call check_div_zero(eps_piv)
      call check_div_zero(V_piv)

      do ll=1, size(phi_end); do kk=1,size(phi_end)
        d2Ndphi2_SR(ll,kk) = delta(kk,ll)*&
            (1.0e0_dp - &
              (eta_piv(ll)/2.0e0_dp/eps_piv(ll))*&
              (V_i_piv(ll)+Z_i(ll))/V_piv&
             ) +&
             (1.0e0_dp/sqrt(2.0e0_dp*eps_piv(ll))/V_piv)*dZ_ij(ll,kk)
      end do; end do

      call assert%check(.not. any(isnan(d2Ndphi2_SR)), __FILE__, __LINE__)

    end function d2Ndphi2_SR

    function eps_SR(phi)
      real(dp), dimension(:), intent(in) :: phi
      real(dp), dimension(size(phi)) :: eps_SR
      real(dp), dimension(size(phi)) :: dV
      real(dp) :: V

      dV = dVdphi(phi)
      V = pot(phi)
      eps_SR = 0.5e0_dp*( dV**2/V**2)

      call assert%check(.not. any(isnan(eps_SR)), __FILE__, __LINE__)

    end function eps_SR

    function eta_SR(phi)
      real(dp), dimension(:), intent(in) :: phi
      real(dp), dimension(size(phi)) :: eta_SR
      real(dp), dimension(size(phi),size(phi)) :: d2V
      real(dp) :: V
      integer :: i

      d2V = d2Vdphi2(phi)
      V = pot(phi)

      do i=1, size(eta_SR)
        eta_SR(i) = d2V(i,i)**2/V
      end do

      call assert%check(.not. any(isnan(eta_SR)), __FILE__, __LINE__)

    end function eta_SR

    function xi_SR(phi)
      real(dp), dimension(:), intent(in) :: phi
      real(dp), dimension(size(phi)) :: xi_SR
      real(dp), dimension(size(phi),size(phi),size(phi)) :: d3V
      real(dp) :: V
      real(dp), dimension(size(phi)) :: dV
      integer :: i

      d3V = d3Vdphi3(phi)
      V = pot(phi)
      dV = dVdphi(phi)

      do i=1, size(xi_SR)
        xi_SR(i) = dV(i)*d3V(i,i,i)**2/V**2
      end do

      call assert%check(.not. any(isnan(xi_SR)), __FILE__, __LINE__)

    end function xi_SR

    !The function Z_i from Battefeld-Easther that encodes all details from the
    !end of inflation surface.  Eq. 31
    function Z_i_BE(phi_end)
      real(dp), dimension(:), intent(in) :: phi_end
      real(dp), dimension(size(phi_end)) :: Z_i_BE

      real(dp), dimension(size(phi_end)) :: eps_end
      real(dp) :: eps, V

      if (HC_approx) then
        Z_i_BE=0e0_dp
        return
      end if

      eps_end = eps_SR(phi_end)
      eps = sum(eps_end)
      V = pot(phi_end)

      !Check for division by zero
      call check_div_zero(eps)

      Z_i_BE = V*eps_end/eps - V_i_sum_sep(phi_end)

      call assert%check(.not. any(isnan(Z_i_BE)), __FILE__, __LINE__)

    end function Z_i_BE

    !Deriv of Z_i wrt fields at horiz cross
    !Battefeld-Easther Eq. 33
    function dZdphi_ij_BE(phi_pivot,phi_end)
      real(dp), dimension(:), intent(in) :: phi_pivot, phi_end
      real(dp), dimension(size(phi_end),size(phi_end)) :: dZdphi_ij_BE

      real(dp), dimension(size(phi_end)) :: eps_end, eps_piv, eta_end
      real(dp) :: eps_t_end, V_end, V_piv
      real(dp), dimension(size(phi_end),size(phi_end)) :: delta

      integer :: ii, jj, ll, kk

      if (HC_approx) then
        dZdphi_ij_BE=0e0_dp
        return
      end if

      eps_end = eps_SR(phi_end)
      eps_piv = eps_SR(phi_pivot)
      eps_t_end = sum(eps_end)
      V_end = pot(phi_end)
      V_piv = pot(phi_pivot)
      eta_end = eta_SR(phi_end)

      !Check for division by zero
      call check_div_zero(eps_piv)
      call check_div_zero(eps_t_end)
      call check_div_zero(V_piv)

      !Identity matrix
      delta=0e0_dp
      do ll=1, size(phi_end)
        delta(ll,ll) = 1.0e0_dp
      end do

      !Summation over jj
      dZdphi_ij_BE = 0e0_dp
      do ll=1, size(phi_end); do kk=1,size(phi_end)
        do jj=1,size(phi_end)
          dZdphi_ij_BE(ll,kk) = dZdphi_ij_BE(ll,kk) + &
            (-V_end**2/V_piv)*sqrt(2.0e0_dp/eps_piv(kk))*&
            (&
              eps_end(jj)*&
              ((eps_end(ll)/eps_t_end) - delta(ll,jj))*&
              ((eps_end(kk)/eps_t_end) - delta(kk,jj))*&
              (1.0e0_dp - (eta_end(jj)/eps_t_end))&
            )
        end do
      end do; end do

      call assert%check(.not. any(isnan(dZdphi_ij_BE)), __FILE__, __LINE__)

    end function dZdphi_ij_BE

    !For a sum-separable potential V=\sum_i V_i.  This returns only the V_i part
    function V_i_sum_sep(phi)
      real(dp), dimension(:), intent(in) :: phi
      real(dp), dimension(size(phi)) :: V_i_sum_sep

      real(dp), dimension(:,:), allocatable :: vparams_temp
      integer :: vrows, jj
      real(dp) :: V

      !The idea: make temp copy of vparams; change vparams as if it had only the
      !one field; get V; restore vparams
      !NB: vparams(vrows,num_inflaton)

      vrows = size(vparams,1)

      allocate(vparams_temp(size(vparams,1), size(vparams,2)))
      vparams_temp = vparams

      do jj=1,size(phi)
        deallocate(vparams)
        allocate(vparams(vrows,1))
        vparams(:,1) = vparams_temp(:,jj)
        V_i_sum_sep(jj) = pot((/phi(jj)/))
      end do

      deallocate(vparams)
      allocate(vparams(size(vparams_temp,1), size(vparams_temp,2)))
      vparams = vparams_temp
      deallocate(vparams_temp)

    end function V_i_sum_sep

    !Subroutines for regularizing a 0/0 error in the summations above
    pure subroutine check_div_zero_array(array)
      real(dp), dimension(:), intent(inout) :: array
      integer :: ii

      if (any(abs(array)<div_tol)) then
        do ii=1, size(array)
          if (abs(array(ii))<div_tol) then
            array(ii) = div_tol
          end if
        end do
      end if

    end subroutine check_div_zero_array

    pure subroutine check_div_zero_real(real_)
      real(dp), intent(inout) :: real_

      if (abs(real_)<div_tol) then
        real_ = div_tol
      end if

    end subroutine check_div_zero_real

end module modpk_deltaN


      SUBROUTINE CNVTGLFL(INTEGRIN,REALOUT)

C***********************************************************************
C  Purpose: Properly interpret the bit string that represents a Gould
C  floating point number to obtain the correct floating point number on
C  the target system.
C
C  Method: The bit string that represents the Gould floating point number
C  is passed into the routine as an integer. The sign bit, the bits that
C  represent the exponent or characteristic, and the bits that represent
C  the fraction are picked off using the standard Fortran function IBITS.
C  The following table show the bits and what they represent (sign,
C  exponent etc).
C
C          byte1       byte2    byte3     byte4
C          31 30-24    23-16    15-08     07-00
C          s  e7-e1    f8-f1    f16-f9    f24-f17
C
C
C
C  Here f1 stands for the first bit that is used to represent the
C  fraction, f2 for the second bit used to represent the fraction, etc.,
C  e1 represents the first exponent bit, e2 the second, and s represents
C  the sign bit.  A Gould floating point number is represented by :
C
C  floating point number = -1**signbit * fraction * 2 **((EXPONENT-64)*4)
C
C  !!!!!!Note: for negative numbers the bit string is stored in 2's
C              complement form.  This form must be inverted before the
C              bit string can be properly interpreted
C
C  Reference: Operations Ground Equipment Interface Specification DRL
C             504-02-1 Part1, Document No. E007020;Space Systems/Loral
C
C***********************************************************************

      INTEGER INTEGRIN !The input integer that contains the bit string
      REAL*8 REALOUT !The output floating point number
      INTEGER SIGNBIT !the sign bit
      INTEGER CHARACTS !the integer representation of the exponent
                         !before it is biased

      REAL*8 M1,M2,M3 !components of the fraction;M1 is most significant
      REAL*8 FRACTION !the fraction portion of the floating point number
      REAL*8 EXPONENT !the exponent portion of the floating point number

C***********************************************************************
C  Pick off the sign bit and convert it to an integer (a zero or a one)
C***********************************************************************

      SIGNBIT = IBITS(INTEGRIN,31,1)

C***********************************************************************
C  Check to see if the number is negative, if so, invert the 2's
C  complement notation.  The inversion is done by clearing the sign bit,
C  subtracting one and flipping the bits
C***********************************************************************

      IF (SIGNBIT .EQ. 1) THEN
        INTEGRIN = IBCLR(INTEGRIN,31)
        INTEGRIN = NOT((INTEGRIN-1))
      ENDIF

C***********************************************************************
C  Pick off the exponent bits (7 bits) convert the two bit strings to
C  their integer representation and add to get the unbiased exponent
C  value
C***********************************************************************

      CHARACTS = IBITS(INTEGRIN,24,7)

C***********************************************************************
C  Bias the exponent
C***********************************************************************

      EXPONENT = DFLOAT ((CHARACTS - 64)*4 )

C***********************************************************************
C Pick off the bits strings from the three difference bytes that contain
C fraction bits.  Convert the bit strings to the appropriate fraction.
C***********************************************************************

      M1 = DFLOAT( (IBITS( INTEGRIN,16,8 ) ) )/(2.0D0)**8
      M2 = DFLOAT(IBITS(INTEGRIN,8,8))/(2.0D0)**16
      M3 = DFLOAT(IBITS(INTEGRIN,0,8))/(2.0D0)**24

C***********************************************************************
C  Compute the fraction portion of the floating point number by adding
C  the three fractional components
C***********************************************************************

      FRACTION = M1 +M2 + M3

C***********************************************************************
C  Compute the floating point number according to the defintion of a
C  Gould floating point number.
C***********************************************************************

      REALOUT= FLOAT(1-2*SIGNBIT)*FRACTION*2.0**EXPONENT

      RETURN
      END