c
c**********************************************************************
      subroutine h2d_directcp_vec(nd,wavek,sources,ns,charge,
     $           targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),xdiff,ydiff,rr,r
      real *8 thresh
      complex *16 wavek,pot(nd),z,ima4inv,ima,h0,h1
      complex *16 charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).le.thresh) goto 1000
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         do ii=1,nd
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
         enddo
 1000    continue
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine h2d_directcg_vec(nd,wavek,sources,ns,charge,targ,pot,
     1             grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c     grad  = gradient(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd,2)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh
      complex *16 wavek,pot(nd),grad(nd,2)
      complex *16 h0,h1,cd,z,ima,ima4inv,cdd
      complex *16 charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
c ... Calculate offsets and distance
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
c
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         cdd = -h1*(wavek*ima4inv/r)
c
         do ii = 1,nd
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
            cd = cdd*charge(ii,i)
            grad(ii,1) = grad(ii,1) + cd*xdiff
            grad(ii,2) = grad(ii,2) + cd*ydiff
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine h2d_directch_vec(nd,wavek,sources,ns,charge,targ,
     1           pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target point TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c     grad  = gradient(pot)
c     hess = Hessian(pot)
c
c     The potential,gradient and hessian are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ          :   location of the target
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd,2)  (complex *16)      : gradient is incremented
c     hess(nd,3)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd
      real *8 sources(2,ns),targ(2)
      real *8 xdiff,ydiff,rr,r,thresh
      complex *16 wavek,pot(nd),grad(nd,2),hess(nd,3)
      complex *16 h0,h1,h2z,cd,z,ima,ima4inv,cdd,cdd2,hf1,hf2,hf3
      complex *16 charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
c ... Calculate offsets and distance
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
c
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         cdd = -h1*(wavek*ima4inv/r)
         cdd2 = (wavek*ima4inv/r)/rr
         h2z=(-z*h0+2*h1)
         hf1 = (h2z*xdiff*xdiff-rr*h1)
         hf2 = (h2z*xdiff*ydiff      )
         hf3 = (h2z*ydiff*ydiff-rr*h1)
c
         do ii = 1,nd
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
            cd = cdd*charge(ii,i)
            grad(ii,1) = grad(ii,1) + cd*xdiff
            grad(ii,2) = grad(ii,2) + cd*ydiff
c
            cd = cdd2*charge(ii,i)
            hess(ii,1) = hess(ii,1) + cd*hf1
            hess(ii,2) = hess(ii,2) + cd*hf2
            hess(ii,3) = hess(ii,3) + cd*hf3
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c**********************************************************************
      subroutine h2d_directdp_vec(nd,wavek,sources,ns,dipstr,dipvec,
     $           targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target point TARGET, due to a collection of
c     dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c     pot(ii)  = \sum_j [\grad(H_0(k*|targ-source(*,j)|)) \cdot
c                       dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : calculated potential
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,cdd
      complex *16 dipstr(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
c
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         cdd = h1/r*wavek*ima4inv
c
         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2*h1/z-h0
         h3 = 4*h2/z-h1
         do ii = 1,nd
            cd = cdd*dipstr(ii,i)
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            pot(ii) = pot(ii)+cd*dotprod
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine h2d_directdg_vec(nd,wavek,sources,ns,dipstr,dipvec,
     $           targ,pot,grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potential POT and gradient GRAD
c     at the target point TARGET, due to a collection of
c     dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c
c     pot(ii)  = \sum_j [\grad(H_0(k*|targ-source(*,j)|))
c                      \cdot dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c     The potential and gradient are not computed
c     if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns):   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)   : potential is incremented
c     grad(nd,2)  (complex *16)   : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd),grad(nd,2)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,hxx,hxy,hyy,cdd,cdd2
      complex *16 hf1,hf2,hf3
      complex *16 dipstr(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
c
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
c
         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2*h1/z-h0
         h3 = 4*h2/z-h1
         cdd = h1/r*wavek*ima4inv
         cdd2 = -wavek**2*ima4inv
         hf1 = (h2*(ctheta*ctheta-0.5d0)-h0/2)
         hf2 = (h2*ctheta*stheta             )
         hf3 = (h2*(stheta*stheta-0.5d0)-h0/2)
         do ii = 1,nd
            cd = cdd*dipstr(ii,i)
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            pot(ii) = pot(ii)+cd*dotprod
            cd = cdd2*dipstr(ii,i)
            hxx = cd*hf1
            hxy = cd*hf2
            hyy = cd*hf3
            grad(ii,1) = grad(ii,1) + hxx*dipvec(ii,1,i) +
     1          hxy*dipvec(ii,2,i)
            grad(ii,2) = grad(ii,2) + hxy*dipvec(ii,1,i) +
     1          hyy*dipvec(ii,2,i)
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine h2d_directdh_vec(nd,wavek,sources,ns,dipstr,dipvec,
     $           targ,pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potential POT, gradient GRAD and
c     Hessian HESS at the target point TARGET, due to a collection of
c     dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c
c     pot(ii)  = \sum_j [\grad(H_0(k*|targ-source(*,j)|))
c                     \cdot dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c     The potential,gradient, and hessian are not
c     computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential, gradient,
c                        and hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)   : potential is incremented
c     grad(nd,2)  (complex *16)   : gradient is incremented
c     hess(nd,3)  (complex *16)   : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd),grad(nd,2),hess(nd,3)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,hxx,hxy,hyy
      complex *16 hxxx,hxxy,hxyy,hyyy,cdd,cdd2,hf1,hf2,hf3
      complex *16 hxxx1,hxxy1,hxyy1,hyyy1
      complex *16 dipstr(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
      ima4inv=ima/4
c
      do i = 1,ns
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
c
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
c
         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2*h1/z-h0
         h3 = 4*h2/z-h1
         cdd = h1/r*wavek*ima4inv
         cdd2 = -wavek**2*ima4inv
         hf1 = (h2*(ctheta*ctheta-0.5d0)-h0/2)
         hf2 = (h2*ctheta*stheta             )
         hf3 = (h2*(stheta*stheta-0.5d0)-h0/2)
         hxxx1 = (-h1/2*(-1.5d0)
     $         -h3/2*(+ctheta*ctheta-0.5d0-stheta*stheta)
     $         )*ctheta
         hxxy1 = (-h1/2*(-0.5d0)
     $         -h3/2*(1.5d0*ctheta*ctheta-0.5d0*stheta*stheta)
     $         )*stheta
         hxyy1 = (-h1/2*(-0.5d0)
     $         -h3/2*(1.5d0*stheta*stheta-0.5d0*ctheta*ctheta)
     $         )*ctheta
         hyyy1 = (-h1/2*(-1.5d0)
     $         -h3/2*(+stheta*stheta-0.5d0-ctheta*ctheta)
     $         )*stheta

         do ii = 1,nd
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            cd = cdd*dipstr(ii,i)
            pot(ii) = pot(ii)+cd*dotprod
            cd = cdd2*dipstr(ii,i)
            hxx = cd*hf1
            hxy = cd*hf2
            hyy = cd*hf3
            grad(ii,1) = grad(ii,1) + hxx*dipvec(ii,1,i) +
     $         hxy*dipvec(ii,2,i)
            grad(ii,2) = grad(ii,2) + hxy*dipvec(ii,1,i) +
     $         hyy*dipvec(ii,2,i)
c
            cd = -wavek**3*dipstr(ii,i)*ima4inv
            hxxx = cd*hxxx1
            hxxy = cd*hxxy1
            hxyy = cd*hxyy1
            hyyy = cd*hyyy1
            hess(ii,1) = hess(ii,1) + hxxx*dipvec(ii,1,i) +
     $          hxxy*dipvec(ii,2,i)
            hess(ii,2) = hess(ii,2) + hxxy*dipvec(ii,1,i) +
     $           hxyy*dipvec(ii,2,i)
            hess(ii,3) = hess(ii,3) + hxyy*dipvec(ii,1,i) +
     $           hyyy*dipvec(ii,2,i)
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c**********************************************************************
      subroutine h2d_directcdp_vec(nd,wavek,sources,ns,
     $     charge,dipstr,dipvec,targ,pot,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potential POT
c     at the target point TARGET, due to a collection of
c     charges and dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c     pot  = H_0(k*r)*(eye/4)
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c              + \sum_j [\grad(H_0(k*|targ-source(*,j)|))
c                    \cdot dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c     The potential is not
c     computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr        :   dipole strengths
c     dipvec(nd,2,ns):   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,cdd
      complex *16 dipstr(nd,ns),charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
c ... Calculate offsets and distance
c
      ima4inv=ima/4
c
      do i = 1,ns
c
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000

         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
c
         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2*h1/z-h0
         h3 = 4*h2/z-h1
         cdd = h1/r*wavek*ima4inv
         do ii = 1,nd
            cd = cdd*dipstr(ii,i)
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            pot(ii) = pot(ii) + cd*dotprod
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c**********************************************************************
      subroutine h2d_directcdg_vec(nd,wavek,sources,ns,
     $     charge,dipstr,dipvec,targ,pot,grad,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potential POT
c     at the target point TARGET, due to a collection of
c     charges and dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c     pot  = H_0(k*r)*(eye/4)
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c              + \sum_j [\grad(H_0(k*|targ-source(*,j)|))
c                    \cdot dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c
c     The potential and gradient are not
c     computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns):   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd,2) (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd),grad(nd,2)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,cdd,cdd2
      complex *16 hxx,hxy,hyy,hf1,hf2,hf3
      complex *16 dipstr(nd,ns),charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
c ... Calculate offsets and distance
c
      ima4inv=ima/4
c
      do i = 1,ns
c
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         cdd = -h1*(wavek*ima4inv/r)
         do ii = 1,nd
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
            cd = cdd*charge(ii,i)
            grad(ii,1) = grad(ii,1) + cd*xdiff
            grad(ii,2) = grad(ii,2) + cd*ydiff
         enddo
c
         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2.0d0*h1/z-h0
         h3 = 4.0d0*h2/z-h1
         cdd = h1/r*wavek*ima4inv
         cdd2 = -wavek**2*ima4inv
         hf1 = (h2*(ctheta*ctheta-0.5d0)-h0/2)
         hf2 = (h2*ctheta*stheta             )
         hf3 = (h2*(stheta*stheta-0.5d0)-h0/2)
         do ii = 1,nd
            cd = cdd*dipstr(ii,i)
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            pot(ii) = pot(ii)+cd*dotprod
            cd = cdd2*dipstr(ii,i)
            hxx = cd*hf1
            hxy = cd*hf2
            hyy = cd*hf3
            grad(ii,1) = grad(ii,1) + hxx*dipvec(ii,1,i) +
     $          hxy*dipvec(ii,2,i)
            grad(ii,2) = grad(ii,2) + hxy*dipvec(ii,1,i) +
     $          hyy*dipvec(ii,2,i)
         enddo
 1000 continue
      enddo
      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine h2d_directcdh_vec(nd,wavek,sources,ns,
     $     charge,dipstr,dipvec,targ,pot,grad,hess,thresh)
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potential POT
c     at the target point TARGET, due to a collection of
c     charges and dipoles at SOURCE(2,ns).
c     The scaling is that required of the delta function
c     response: i.e.,
c
c     pot  = H_0(k*r)*(eye/4)
c
c     pot(ii)  = \sum_j H_0(k*|targ-source(*,j)|)*(eye/4)*charge(ii,j)
c
c              + \sum_j [\grad(H_0(k*|targ-source(*,j)|))
c                 \cdot dipvec(ii,*,j)]
c                      *(eye/4)*dipstr(ii,j)
c
c     The potential, gradient and hessian are not
c     computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     |zk|*R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     wavek         :   Helmholtz parameter
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     dipvec(nd,2,ns) :   dipole vectors
c     targ          :   location of the target
c     thresh        :   threshold for computing potential, gradient,
c                       and hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd)     (complex *16)      : potential is incremented
c     grad(nd,2)  (complex *16)      : gradient is incremented
c     hess(nd,3)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns, ifexpon,ii,nd
      real *8 sources(2,ns),targ(2),dipvec(nd,2,ns)
      real *8 xdiff,ydiff,rr,r,ctheta,stheta,dotprod
      real *8 thresh
      complex *16 wavek,pot(nd),grad(nd,2),hess(nd,3)
      complex *16 h0,h1,h2,h3,cd,z,ima,ima4inv,cdd,cdd2
      complex *16 hxx,hxy,hyy,h2z
      complex *16 hxxx,hxxy,hxyy,hyyy
      complex *16 hxxx1,hxxy1,hxyy1,hyyy1,hf1,hf2,hf3
      complex *16 dipstr(nd,ns),charge(nd,ns)
      data ima/(0.0d0,1.0d0)/
c
c ... Calculate offsets and distance
c
      ima4inv=ima/4
c
      do i = 1,ns
c
         xdiff=targ(1)-sources(1,i)
         ydiff=targ(2)-sources(2,i)
         rr=xdiff*xdiff+ydiff*ydiff
         r=sqrt(rr)
         z=wavek*r
         if(abs(z).lt.thresh) goto 1000
         ifexpon = 1
         call hank103(z, h0, h1, ifexpon)
         do ii = 1,nd
            pot(ii) = pot(ii) + h0*charge(ii,i)*ima4inv
            cd = -h1*(wavek*charge(ii,i)*ima4inv/r)
            grad(ii,1) = grad(ii,1) + cd*xdiff
            grad(ii,2) = grad(ii,2) + cd*ydiff
            cd = (wavek*charge(ii,i)*ima4inv/r)/rr
            h2z=(-z*h0+2*h1)
            hess(ii,1) = hess(ii,1) + cd*(h2z*xdiff*xdiff-rr*h1)
            hess(ii,2) = hess(ii,2) + cd*(h2z*xdiff*ydiff      )
            hess(ii,3) = hess(ii,3) + cd*(h2z*ydiff*ydiff-rr*h1)
         enddo

         ctheta=xdiff/r
         stheta=ydiff/r
         h2 = 2*h1/z-h0
         h3 = 4*h2/z-h1
         cdd = h1/r*wavek*ima4inv
         cdd2 = -wavek**2*ima4inv
         hf1 = (h2*(ctheta*ctheta-0.5d0)-h0/2)
         hf2 = (h2*ctheta*stheta             )
         hf3 = (h2*(stheta*stheta-0.5d0)-h0/2)
         hxxx1 = (-h1/2*(-1.5d0)
     $         -h3/2*(+ctheta*ctheta-0.5d0-stheta*stheta)
     $         )*ctheta
         hxxy1 = (-h1/2*(-0.5d0)
     $         -h3/2*(1.5d0*ctheta*ctheta-0.5d0*stheta*stheta)
     $         )*stheta
         hxyy1 = (-h1/2*(-0.5d0)
     $         -h3/2*(1.5d0*stheta*stheta-0.5d0*ctheta*ctheta)
     $         )*ctheta
         hyyy1 = (-h1/2*(-1.5d0)
     $         -h3/2*(+stheta*stheta-0.5d0-ctheta*ctheta)
     $         )*stheta
c
         do ii = 1,nd
            cd = cdd*dipstr(ii,i)
            dotprod = xdiff*dipvec(ii,1,i)+ydiff*dipvec(ii,2,i)
            pot(ii) = pot(ii)+cd*dotprod
            cd = cdd2*dipstr(ii,i)
            hxx = cd*hf1
            hxy = cd*hf2
            hyy = cd*hf3
            grad(ii,1) = grad(ii,1) + hxx*dipvec(ii,1,i) +
     $         hxy*dipvec(ii,2,i)
            grad(ii,2) = grad(ii,2) + hxy*dipvec(ii,1,i) +
     $         hyy*dipvec(ii,2,i)
            cd = -wavek**3*dipstr(ii,i)*ima4inv
            hxxx = cd*hxxx1
            hxxy = cd*hxxy1
            hxyy = cd*hxyy1
            hyyy = cd*hyyy1
            hess(ii,1) = hess(ii,1) + hxxx*dipvec(ii,1,i) +
     $          hxxy*dipvec(ii,2,i)
            hess(ii,2) = hess(ii,2) + hxxy*dipvec(ii,1,i) +
     $          hxyy*dipvec(ii,2,i)
            hess(ii,3) = hess(ii,3) + hxyy*dipvec(ii,1,i) +
     $           hyyy*dipvec(ii,2,i)
         enddo
 1000 continue
      enddo
      return
      end
c
c


c> \file formt.f

c> \brief Forms the upper half of the pos. def. and symm. T.
c>
c> This subroutine forms the upper half of the pos. def. and symm.
c> T = theta*SS + L*D^(-1)*L', stores T in the upper triangle
c> of the array wt, and performs the Cholesky factorization of T
c> to produce J*J', with J' stored in the upper triangle of wt.
c>
c> @param m history size of approximated Hessian
c> @param wt part of L-BFGS matrix
c> @param sy part of L-BFGS matrix
c> @param ss part of L-BFGS matrix
c> @param col On entry col is the actual number of variable metric
c>               corrections stored so far.

c>            On exit col is unchanged.
c> @param theta On entry theta is the scaling factor specifying B_0 = theta I.

c>              On exit theta is unchanged.
c>
c> @param info error/success indicator
      subroutine formt(m, wt, sy, ss, col, theta, info)

      integer          m, col, info
      double precision theta, wt(m, m), sy(m, m), ss(m, m)
c
c                           *  *  *
c
c     NEOS, November 1994. (Latest revision June 1996.)
c     Optimization Technology Center.
c     Argonne National Laboratory and Northwestern University.
c     Written by
c                        Ciyou Zhu
c     in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c     ************

      integer          i,j,k,k1
      double precision ddum
      double precision zero
      parameter        (zero=0.0d0)

c     Form the upper half of  T = theta*SS + L*D^(-1)*L',
c        store T in the upper triangle of the array wt.

      do 52 j = 1, col
         wt(1,j) = theta*ss(1,j)
  52  continue
      do 55 i = 2, col
         do 54 j = i, col
            k1 = min(i,j) - 1
            ddum  = zero
            do 53 k = 1, k1
               ddum  = ddum + sy(i,k)*sy(j,k)/sy(k,k)
  53        continue
            wt(i,j) = ddum + theta*ss(i,j)
  54     continue
  55  continue

c     Cholesky factorize T to J*J' with
c        J' stored in the upper triangle of wt.

      !call dpofa(wt,m,col,info)
      call dpotrf('U',col,wt,m,info)
      if (info .ne. 0) then
         info = -3
      endif

      return

      end


C      PROGRAM INTPTDAC
CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+C-CCCCCCC+
C
C GRID FILE STRUCTURE:
C
C  This FORTRAN program will interpolate values from a WORLD-WIDE grid file.
C  The grid data are in subsequent records arranged from North to South, West
C  to East, i.e. record 1 would be the northern most latitude band of data.
C
C-------------------------------------------------------------------------------
C
C  Several interpolation schemes are possible using this program.  By setting
C  the parameter IWINDO to a particular value, one may use Bi-linear interpo-
C  lation or a spline interpolation with a window of size of IWINDO  x IWINDO.
C  Check the subroutine "INTERP" for more information.
C
C  This program is set up to extend the longitude values by a minimum of 2 posts
C  on the positive side of the east longitude limit and a minimum of 2 posts to
C  the negative side of the west longitude.
C
C-------------------------------------------------------------------------------
C
C  Change the following variables in the parameter statements below to match
C  the grid file information and desired interpolation method:
C
C                IWINDO = Size of window of interpolation and method.
C                             IWINDO=0 gives bilinear interpolation.
C                             Check subroutine "INTERP" below for more
C                             information.
C
C                ****NOTE: If IWINDO=0 be sure to set NBDR=4 *****
C                             In general, NBDR=2*IWINDO
C
C
C                NLAT = Number of values in latitude.
C                NLON = Number of values in longitude. (Leave the NBDR
C                            parameter in the NLON parameter declaration.
C                            This controls the extension of the grid in
C                            longitude.)
C                DLAT = Spacing in latitude.
C                DLON = Spacing in longitude.
C
C-------------------------------------------------------------------------------
C
C FILE INFORMATION:
C
C  INPUT DATA GRID: UNIT = 1
C
C    For structure see above.
C
C
C  INPUT DATA POINTS:  UNIT = 11
C
C     The input file of points to be interpolated is arranged as:
C
C                       latitude   longitude
C                         (decimal degrees)
C
C
C OUPUT OF INTERPOLATED POINTS:  UNIT = 20
C
C    The output file of interpolated points is arranged as:
C
C                       latitude   longitude    value
C                        (decimal degrees)
C
C-------------------------------------------------------------------------------
C
C  This program was provided by Professor Richard H. Rapp of The Ohio State
C    University, December, 1996.  It was put into its present form by the National
C    Imagery and Mapping Agency (NIMA), December, 1996.
C
C                       Name         Date   Reason for Change
C    ------------------------------------------------------------------------
C    Revised:    John Factor       09/2003  use 15 min direct access file
C                John Factor       04/2013  correction for array indexing
CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+CCCCCCCCC+C-CCCCCCC+

      implicit real*8(a-h,o-z)
      real*8 south,north,west,east,dphi,dlam

      PARAMETER(IWINDO=4)
      PARAMETER(NBDR=2*IWINDO)
      PARAMETER(NLAT=721,NLON=(1441+NBDR),DLAT=0.25D0,DLON=0.25D0)
      integer*2 A1(NLON)
      REAL*4 H (nlat, nlon)
      CHARACTER NAM*41
      REAL*8 XMIN,XMAX,RDX
      DATA XMIN, XMAX, RDX, NAM/-50.,50., 2.,
     .     'GEOID HTS'/

      CALL HISTO(6,1,NAM,XMIN,XMAX,RDX,1,0.D0,1)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCC                                                           CCCCCCCCCCC
CCCCCCCCCC                 INPUT/OUPUT FILE NAMES                    CCCCCCCCCCC
CCCCCCCCCC            MAKE CHANGES TO FILE NAMES BELOW               CCCCCCCCCCC
CCCCCCCCCC                                                           CCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c data grid file
      open(1,
     .     file='WW15MGH.DAC',
     .     form='unformatted',
     .     access='direct',
     .     recl=(NLON-NBDR-1)*2,
     .     convert='big_endian',
     .     status='old')

c input file of points to be interpolated
      open(11,file='INPUT.DAT',status='old')

c output file of interpolated values
      open(20,file='OUTINTPT.DAT')

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c input grid boundary and spacing
      south = -90.d0
      north = 90.d0
      west = 0.d0
      east = 360.d0
      dphi = 0.25d0
      dlam = 0.25d0

C read input grid file and store in array H
      DO I=1,NLAT
         READ(1,rec=I) (A1(K),K=1,nlon-nbdr-1)
         A1(nlon-nbdr)=A1(1)
         DO J=1,nlon-nbdr
            H(NLAT-I+1,J+nbdr/2)=A1(J)/100.d0
         ENDDO
         DO K=1,nbdr/2
            H(NLAT-I+1,K)=A1(nlon-nbdr-nbdr/2-1+K)/100.d0
3           H(NLAT-I+1,k+nlon-nbdr/2)=A1(K+1)/100.d0
         ENDDO
      ENDDO

c read in the points to be interpolated
80    READ(11,*,END=100) FLAT,FLON

c call interpolation subroutine
      CALL INTERP(IWINDO,12.D0,H,south,west-nbdr/2*dlam,DLAT,DLON,
     .            NLAT,NLON,NLAT,NLON,FLAT,FLON,UN)

      CALL HISTO(6,2,NAM,XMIN,XMAX,RDX,1,UN,1)

c output the interpolated points
       WRITE(20,997)FLAT,FLON,UN
997   format(2f14.7,f12.7)

      GOTO 80

100   CONTINUE

      CALL HISTO(6,3,NAM,XMIN,XMAX,RDX,1,0.D0,1)

      STOP
      END
      SUBROUTINE INTERP(IWINDO,DMIN,H,PHIS,DLAW,DDFI,DDLA,NPHI,NDLA,
     .                  IPDIM,ILDIM,PHI,DLA,VALINT)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE FOR INTERPOLATION OF VALUES FROM A STANDARD DTM-GRID  C
C     TO INDIVIDUAL STATION LOCATIONS.                                 C
C                                                                      C
C                                                                      C
C     INPUT PARAMETERS...                                              C
C     ===================                                              C
C     IWINDO...    A SPLINE WINDOW OF SIZE 'IWINDO' X 'IWINDO' WILL BE C
C                  USED AROUND EACH STATION. IF 'IWINDO' IS 0 OR 1,    C
C                  BILINEAR INTERPOLATION WILL BE USED.                C
C     DMIN...      MINIMUM ACCEPTABLE DISTANCE FROM THE GRID EDGE IN   C
C                  KM (USEFUL FOR FFT GRIDS).                          C
C     H...         2D DATA ARRAY (ELEMENT (1,1) IN SW CORNER).         C
C     PHIS,DLAW... LATITUDE AND LONGITUDE OF SW GRID POINT.            C
C     DDFI,DDLA... GRID SPACING IN LATITUDE AND LONGITUDE DIRECTION.   C
C     NPHI,NDLA... NUMBER OF GRID POINTS IN LATITUDE AND LONGITUDE     C
C                  DIRECTION.                                          C
C     IPDIM,ILDIM..DIMENSIONS OF 2D DATA ARRAY 'H' AS DECLARED IN THE  C
C                  CALLING PROGRAM.                                    C
C     PHI,DLA...   LATITUDE AND LONGITUDE OF INTERPOLATION POINT.      C
C                                                                      C
C                                                                      C
C     OUTPUT PARAMETERS...                                             C
C     ====================                                             C
C     VALINT...    INTERPOLATED VALUE.                                 C
C                                                                      C
C                                                                      C
C     EXECUTION TIME ON CDC 990 IS...                                  C
C     ===============================                                  C
C     +------------------+-------------------+-------------------+     C
C     I  INTERPOLATION   I  OPT=LOW          I  OPT=HIGH         I     C
C     I------------------I-------------------I-------------------I     C
C     I  BILINEAR        I  1.44 MSEC/STAT.  I  1.44 MSEC/STAT.  I     C
C     I  3 X 3 SPLINE    I  1.53 MSEC/STAT.  I  1.51 MSEC/STAT.  I     C
C     I  5 X 5 SPLINE    I  1.70 MSEC/STAT.  I  1.67 MSEC/STAT.  I     C
C     I  7 X 7 SPLINE    I  2.02 MSEC/STAT.  I  1.74 MSEC/STAT.  I     C
C     I  9 X 9 SPLINE    I  2.31 MSEC/STAT.  I  2.00 MSEC/STAT.  I     C
C     +------------------+-------------------+-------------------+     C
C                                                                      C
C                                                                      C
C     PROGRAM CREATION BY...   H. DENKER          MAY 30, 1987         C
C                              H. DENKER          MARCH 13, 1989       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PARAMETER(IPA1=20)
      IMPLICIT REAL*8(A-H,O-Z)
      LOGICAL LODD
      REAL*4 H(IPDIM,ILDIM)
      DIMENSION A(IPA1),R(IPA1),Q(IPA1),HC(IPA1)
      IDIM1=IPA1
      RHO=57.29577951D0
      REARTH=6371000.D0
      IF(IWINDO.LT.2) IWINDO=2
      IF(IWINDO.GT.IDIM1) IWINDO=IDIM1
      ILIM=DMIN*1000.*RHO/(REARTH*DDFI)
      JLIM=DMIN*1000.*RHO/(REARTH*DDLA*COS((PHIS+DDFI*NPHI/2.)/RHO))
      LODD=(IWINDO/2)*2.NE.IWINDO
      RI=(PHI-PHIS)/DDFI
      RJ=(DLA-DLAW)/DDLA
      IF(LODD) THEN
        I0=RI-0.5
        J0=RJ-0.5
      ELSE
        I0=RI
        J0=RJ
      ENDIF
      I0=I0-IWINDO/2+1
      J0=J0-IWINDO/2+1
      II=I0+IWINDO-1
      JJ=J0+IWINDO-1
      IF(I0.LT.0 .OR. II.GE.NPHI .OR. J0.LT.0 .OR. JJ.GE.NDLA) THEN
        WRITE(6,7008) PHI,DLA
        VALINT=999999.
        RETURN
      ELSEIF(I0.LT.ILIM .OR. II.GT.NPHI-ILIM .OR. J0.LT.JLIM .OR.
     .  JJ.GT.NDLA-JLIM) THEN
c        IF(NPOINT.LE.ILIST) WRITE(6,7009) PHI,DLA
        VALINT=999999.
        RETURN
      ENDIF
7008  FORMAT(' ',2F10.6,' STATION TOO NEAR GRID BOUNDARY  - NO INT.'
     .,' POSSIBLE|')
7009  FORMAT(' ',2F10.6,' STATION OUTSIDE ACCEPTABLE AREA - NO INT.'
     .,' PERFORMED|')
      IF(IWINDO.GT.2) THEN
        DO 110 I=1,IWINDO
          DO 111 J=1,IWINDO
            A(J)=H(I0+I,J0+J)
111       CONTINUE
          CALL INITSP(A,IWINDO,R,Q)
          HC(I)=SPLINE(RJ-J0+1.,A,IWINDO,R)
110     CONTINUE
        CALL INITSP(HC,IWINDO,R,Q)
        VALINT=SPLINE(RI-I0+1.,HC,IWINDO,R)
      ELSE
        VALINT=BILIN(RI+1.,RJ+1.,H,NPHI,NDLA,IPDIM,ILDIM)
      ENDIF
      RETURN
      END
      FUNCTION BILIN(RI,RJ,A,IMAX,JMAX,IADIM,JADIM)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C                           B I L I N                                  C
C                                                                      C
C  INTERPOLATES VALUES IN AN ARRAY A USING BILINEAR                    C
C  (PARABOLIC HYPERBOLOID) INTERPOLATION.                              C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  PARAMETERS:                                                         C
C                                                                      C
C  BILIN...       INTERPOLATED VALUE                                   C
C                                                                      C
C  RI, RJ...      INTERPOLATION ARGUMENT, (1,1) IN LOWER LEFT CORNER,  C
C                 (IMAX, JMAX) IN UPPER RIGHT.                         C
C                                                                      C
C  A...           INTEGER*2 ARRAY WITH ARGUMENTS                       C
C                                                                      C
C  IMAX, JMAX...  NUMBER OF POINTS IN GRID                             C
C                                                                      C
C  IADIM, JADIM...DECLARED DIMENSIONS OF 'A'                           C
C                                                                      C
C  OUTSIDE AREA COVERED BY 'A' THE FUNCTION RETURNS THE VALUE OF       C
C  THE NEAREST BOUNDARY POINT.                                         C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  PROGRAMMER:                                                         C
C  RENE FORSBERG, JULY 1983                                            C
C                                                                      C
C  MODIFICATIONS BY:                                                   C
C  HEINER DENKER, 07/01/1987                                           C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT REAL*8 (A-H, O-Z)
      DIMENSION A(IADIM, JADIM)
      REAL*4 A
      IN = IFRAC(RI)
      IE = IFRAC(RJ)
      RN = RI - IN
      RE = RJ - IE
      IF (IN.LT.1) THEN
        IN = 1
        RN = 0.0
      ELSEIF (IN.GE.IMAX) THEN
        IN = IMAX-1
        RN = 1.0
      ENDIF
      IF (IE.LT.1) THEN
        IE = 1
        RE = 0.0
      ELSEIF (IE.GE.JMAX) THEN
        IE = JMAX-1
        RE = 1.0
      ENDIF
      RNM1=1.-RN
      REM1=1.-RE
      BILIN = RNM1*REM1*A(IN,IE) +
     .RN*REM1*A(IN+1,IE) + RNM1*RE*A(IN,IE+1) +
     .RN*RE*A(IN+1,IE+1)
      RETURN
      END
      SUBROUTINE INITSP(Y, N, R, Q)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C                      I N I T S P                                     C
C                                                                      C
C  INITIALIZATION PROCEDURE FOR FAST 1-DIMENSIONAL EQUIDISTANT         C
C  SPLINE INTERPOLATION, WITH FREE BOUNDARY END CONDITIONS             C
C  REFERENCE: JOSEF STOER: EINFUHRUNG IN DIE NUMERISCHE MATHEMATIK     C
C  I, SPRINGER 1972, PAGE 82 AND 86.                                   C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  PARAMETERS (REAL):                                                  C
C                                                                      C
C  Y...   GIVEN VALUES, Y(1), ..., Y(N)                                C
C                                                                      C
C  R...   SPLINE MOMENTS (1 ... N), TO BE USED BY FUNCTION 'SPLINE'    C
C                                                                      C
C  Q...   WORK-ARRAY, DECLARED AT LEAST 1:N                            C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  RENE FORSBERG, JULY 1983                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION Y(N), R(N), Q(N)
      Q(1) = 0.0
      R(1) = 0.0
      DO 11 K = 2, N-1
        P = Q(K-1)/2+2
        Q(K) = -0.5/P
        R(K) = (3*(Y(K+1)-2*Y(K)+Y(K-1)) - R(K-1)/2)/P
   11 CONTINUE
      R(N) = 0.0
      DO 12 K = N-1, 2, -1
        R(K) = Q(K)*R(K+1)+R(K)
   12 CONTINUE
      RETURN
      END
      FUNCTION SPLINE(X, Y, N, R)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C                          S P L I N E                                 C
C                                                                      C
C  FAST ONE-DIMENSIONAL EQUIDISTANT SPLINE INTERPOLATION FUNCTION.     C
C  REFERENCE: JOSEF STOER: EINFUHRUNG IN DIE NUMERISCHE MATHEMATIK     C
C  I, SPRINGER 1972, PAGE 81.                                          C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  PARAMETERS:                                                         C
C                                                                      C
C  X...  INTERPOLATION ARGUMENT (REAL), X = 1 FIRST DATA-POINT,        C
C        X = N LAST DATA-POINT. OUTSIDE THE RANGE LINEAR EXTRA-        C
C        POLATION IS USED.                                             C
C                                                                      C
C  Y...  REAL*8 ARRAY, 1 .. N : DATA VALUES                            C
C                                                                      C
C  R...  DO: SPLINE MOMENTS CALCULATED BY SUBROUTINE 'INITSP'          C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C  PROGRAMMER:                                                         C
C  RENE FORSBERG, JUNE 1983                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT REAL*8 (A-H, P-Z)
      DIMENSION Y(N), R(N)
      IF (X.LT.1) THEN
        SPLINE = Y(1) + (X-1)*(Y(2)-Y(1)-R(2)/6)
      ELSEIF (X.GT.N) THEN
        SPLINE = Y(N) + (X-N)*(Y(N)-Y(N-1)+R(N-1)/6)
      ELSE
        J = IFRAC(X)
        XX = X - J
        SPLINE = Y(J) +
     .           XX * ((Y(J+1)-Y(J)-R(J)/3-R(J+1)/6) +
     .           XX * (R(J)/2 +
     .           XX * (R(J+1)-R(J))/6))
      ENDIF
      RETURN
      END
      FUNCTION IFRAC(R)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C                    F U N C T I O N   I F R A C                       C
C                  ===============================                     C
C                                                                      C
C  SUBROUTINE GIVING TRUE INTEGER PART OF A REAL E.G.                  C
C                                                                      C
C    FOR   1. = R < 2.   IS    IFRAC = 1                               C
C    FOR   0. = R < 1.   IS    IFRAC = 0                               C
C    FOR  -1. = R < 0.   IS    IFRAC =-1                               C
C    FOR  -2. = R <-1.   IS    IFRAC =-2                               C
C                                                                      C
C  RF, JUNE 1983                                                       C
C  HD, JANUARY 1987                                                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT REAL*8(A-H,O-Z)
      IFRAC=R
      IF (R.GE.0) RETURN
      IF (R.EQ.IFRAC) RETURN
      IFRAC = IFRAC - 1
      RETURN
      END
      SUBROUTINE HISTO(IUN6,IENT,NAM,XMIN,XMAX,RDX,J,X,NEWP)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE HISTO, VERSION 830909 FTN5.                           C
C                                                                      C
C     THE SUBROUTINE HISTO COMPUTES UP TO 20 HISTOGRAMS FOR DIFFERENT  C
C     PARAMETERS IN PARALLEL EXECUTION AND PRINTS THE HISTOGRAMS       C
C     ON LINE PRINTER.                                                 C
C                                                                      C
C     INPUT PARAMETER DESCRIPTION...                                   C
C     ==============================                                   C
C                                                                      C
C     IUN6...      UNIT NUMBER OF LINE PRINTER OUTPUT. THIS UNIT HAS   C
C                  TO BE DECLARED AS OUTPUT IN THE PROGRAM CARD.       C
C                  (EXAMPLE...IUN6=6, DECLARE TAPE6=OUTPUT IN THE      C
C                  PROGRAM CARD).                                      C
C     IENT...      ENTRY PARAMETER FOR SUBROUTINE HISTO.               C
C                  FOR IENT=1, SUBROUTINE HISTO WILL BE INITIALIZED    C
C                  FOR PARAMETER NO. J.                                C
C                  FOR IENT=2, THE HISTOGRAM WILL BE UPDATED FOR       C
C                  SAMPLE VALUE X OF PARAMETER NO. J.                  C
C                  FOR IENT=3, THE HISTOGRAM WILL BE PRINTED FOR       C
C                  PARAMETER NO. J AND AGAIN INITIALIZED FOR PARAMETER C
C                  NO. J.                                              C
C     NAM...       ARRAY OF ALPHANUMERIC PARAMETER NAMES TO BE PRINTED C
C                  WITH FORMAT A10.                                    C
C     XMIN...      ARRAY OF LOWER BORDERS FOR HISTOGRAMS.              C
C     XMAX...      ARRAY OF UPPER BORDERS FOR HISTOGRAMS.              C
C     RDX...       ARRAY OF INCREMENTS FOR HISTOGRAMS.                 C
C     J...         PARAMETER NO.                                       C
C     X...         SAMPLE VALUE OF PARAMETER NO. J.                    C
C     NEWP...      PARAMETER FOR BEGINNING A NEW PAGE.                 C
C                  NEWP=1...HISTOGRAM WILL BE PRINTED ON A NEW PAGE    C
C                  FOR ENTRY PARAMETER IENT=3.                         C
C                  X HAS TO BE DEFINED ONLY FOR ENTRY PARAMETER IENT=2.C
C                                                                      C
C     PROGRAM CREATION...    820420 BY G.WEBER,                        C
C                            INSTITUT FUER ERDMESSUNG,                 C
C                            UNIVERSITAET HANNOVER,                    C
C                            NIENBURGER STR.6,                         C
C                            D-3000 HANNOVER 1,                        C
C                            FEDERAL REPUBLIC OF GERMANY.              C
C     PROGRAM MODIFICATION...830725 BY H.-G.WENZEL                     C
C     PROGRAM MODIFICATION...830909 BY H.-G.WENZEL                     C
C     PROGRAM MODIFICATION...890302 BY H. DENKER (FOR IBM)             C
C                                                                      C
C**********************************************************************C
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER NAM*41, IZEI*1
      DIMENSION NAM(30),XMIN(30),XMAX(30),RDX(30),KMAX(30)
      DIMENSION RMX(30),RMS(30),RXMIN(30),RXMAX(30)
      DIMENSION N(52,30),IZEI(40)
      SAVE
      COMMON/HIS/ N
C     LEVEL2,/HIS/
      IF(IENT.NE.2) GOTO 100
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     IENT=2. UPDATING OF ARRAYS N,RMX,RMS FOR PARAMETER NO. J         C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      K=(X-XMIN(J))/RDX(J)+2.
      IF(K.LT.1) K=1
      IF(K.GT.KMAX(J)) K=KMAX(J)
      N(K,J)=N(K,J)+1
      RMX(J)=RMX(J)+X
      RMS(J)=RMS(J)+X*X
      IF(X.LT.RXMIN(J)) RXMIN(J)=X
      IF(X.GT.RXMAX(J)) RXMAX(J)=X
      RETURN
  100 IF(IENT.NE.1) GOTO 300
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     IENT=1. INITIALIZATION OF SUBROUTINE HISTO FOR PARAMETER NO. J.  C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 110 K=1,52
  110 N(K,J)=0
      RMX(J)=0.
      RMS(J)=0.
      RXMIN(J)= 999999.9
      RXMAX(J)=-999999.9
      KMAX(J)=(XMAX(J)-XMIN(J))/RDX(J)+2.
      IF(KMAX(J).GT.52) KMAX(J)=52
      RETURN
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     IENT=3. PRINT HISTOGRAM FOR PARAMETER NO. J.                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  300 NSU=0
      NMA=0
      DO 310 K=1,KMAX(J)
      IF(N(K,J).GT.NMA) NMA=N(K,J)
  310 NSU=NSU+N(K,J)
      IF(NSU.EQ.0) RETURN
      SCALE=40./REAL(NMA)
      IF(NEWP.EQ.1) WRITE(IUN6,7006)
      WRITE(IUN6,7000)
      RMX(J)=RMX(J)/REAL(NSU)
      RRMS=SQRT(RMS(J)/REAL(NSU))
      RMS(J)=RMS(J)-RMX(J)*RMX(J)*REAL(NSU)
      RMS(J)=SQRT(ABS(RMS(J))/REAL(NSU))
      WRITE(IUN6,7003) NAM(J),NSU,RMX(J),RMS(J),RRMS,RXMIN(J),RXMAX(J)
      DO 320 K=1,KMAX(J)
      DO 330 L=1,40
  330 IZEI(L)=' '
      IZEI(1)='.'
      IZEIE=REAL(N(K,J))*SCALE
      IF(IZEIE.LE.40) GOTO 340
      IZEI(40)='+'
      IZEIE=40
  340 CONTINUE
      IF(IZEIE.LT.1) GOTO 360
      DO 350 L=1,IZEIE
  350 IZEI(L)='*'
  360 CONTINUE
      XMI=REAL(K-2)*RDX(J)+XMIN(J)
      XMA=REAL(K-1)*RDX(J)+XMIN(J)
      PROZ=REAL(N(K,J))/REAL(NSU)
      IF(K.NE.1.AND.K.NE.KMAX(J)) WRITE(IUN6,7001) K-1,XMI,XMA,PROZ,
     1 N(K,J),(IZEI(L),L=1,40)
      IF(K.EQ.1) WRITE(IUN6,7002) K-1,XMA,PROZ,N(K,J),(IZEI(L),L=1,40)
      IF(K.EQ.KMAX(J)) WRITE(IUN6,7004) K-1,XMI,PROZ,N(K,J),
     1 (IZEI(L),L=1,40)
  320 CONTINUE
  370 WRITE(IUN6,7005)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     RE-INITIALIZATION FOR PARAMETER NO.J.                            C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 380 K=1,52
  380 N(K,J)=0
      RMX(J)=0.
      RMS(J)=0.
      RXMIN(J)=999999.9
      RXMAX(J)=-999999.9
      RETURN
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     FORMAT STATEMENTS.                                               C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 7000 FORMAT(/' SUBROUTINE HISTO, VERSION 03/02/89.'/
     .        ' ===================================')
 7001 FORMAT(1X,I3,F10.3,' ... ',F10.3,F10.3,I10,3X,40A1)
 7002 FORMAT(1X,I3,' -INFINITY ... ',F10.3,F10.3,I10,3X,60A1)
 7004 FORMAT(1X,I3,F10.3,' ...   INFINITY',F10.3,I10,3X,40A1)
 7003 FORMAT(
     .' HISTOGRAM FOR PARAMETER     ',10X,A10/
     .' NUMBER OF SAMPLE VALUES     ',10X,I10/
     .' MEAN OF SAMPLE VALUES       ',10X,F10.3/
     .' STD. DEV. OF SAMPLE VALUES  ',10X,F10.3/
     .' RMS OF SAMPLE VALUES        ',10X,F10.3/
     .' MINIMUM SAMPLE VALUE        ',10X,F10.3/
     .' MAXIMUM SAMPLE VALUE        ',10X,F10.3/)
 7005 FORMAT(/' END OF SUBROUTINE HISTO')
 7006 FORMAT(1H1)
      END


subroutine tandem1(x, y, n, h, m, nml)
  implicit none
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !!! nml => 0: Normal filtering
  !!! nml < 0: Reverse filtering
  !!! x(n) : input data
  !!! y(n) : output(filtered) data
  !!!        work well if same name with input data
  !!! h(4 * m) : filter coefficient calculated by calc_[bhl]pf_coef.f90
  !!! m : filter order calclated by calc_[bhl]_pf_order.f90
  !!!
  !!! Author   : Masashi Ogiso (masashi.ogiso@gmail.com)
  !!! Reference: Saito, M. (1978) An automatic design algorithm for band selective recursive
  !!!                             digital filters, Geophysical Exploration, 31(4), 240-263 (In Japanese)
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  integer, intent(IN) :: n, m, nml
  real*8, intent(IN) :: x(n), h(4 * m)
  real*8, intent(OUT) :: y(n)

  integer :: i, j
  real*8 :: tmp_h(4)

  do j = 1, 4
    tmp_h(j) = h(j)
  enddo

  call recfil1(x, y, n, tmp_h, nml)

  if(m .gt. 1) then
    do i = 2, m
      do j = 1, 4
        tmp_h(j) = h(4 * (i - 1) + j)
      enddo
      call recfil1(y, y, n, tmp_h, nml)
    enddo
  endif

  return
end subroutine tandem1

subroutine recfil1(x, y, n, h, nml)
  implicit none
  integer, intent(IN) :: n, nml
  real*8, intent(IN) :: x(n), h(4)
  real*8, intent(OUT) :: y(n)

  integer :: j, jd, i
  real*8 :: a, aa, b, bb, u1, u2, u3, v1, v2, v3

  if(nml .ge. 0) then
    j = 1
    jd = 1
  else
    j = n
    jd = -1
  endif

  a = h(1)
  aa = h(2)
  b = h(3)
  bb = h(4)
  u1 = 0.0d0
  u2 = 0.0d0
  v1 = 0.0d0
  v2 = 0.0d0

  do i = 1, n
    u3 = u2
    u2 = u1
    u1 = x(j)
    v3 = v2
    v2 = v1
    v1 = u1 + a * u2 + aa * u3 - b * v2 - bb * v3
    y(j) = v1
    j = j + jd
  enddo

  return
end subroutine recfil1

subroutine tandem2(x, y, n, h, m, nml, uv)
  implicit none

  integer, intent(IN) :: n, m, nml
  real*8, intent(IN) :: x(n), h(4 * m)
  real*8, intent(OUT) :: y(n)
  real*8, intent(INOUT) :: uv(4 * m)

  integer :: i, j
  real*8 :: tmp_h(4), tmp_uv(4)

  tmp_h(1 : 4) = h(1 : 4)
  tmp_uv(1 : 4) = uv(1 : 4)

  call recfil2(x, y, n, tmp_h, nml, tmp_uv)
  uv(1 : 4) = tmp_uv(1 : 4)

  if(m .gt. 1) then
    do i = 2, m
      do j = 1, 4
        tmp_h(j) = h(4 * (i - 1) + j)
        tmp_uv(j) = uv(4 * (i - 1) + j)
      enddo
      call recfil2(y, y, n, tmp_h, nml, tmp_uv)
      do j = 1, 4
        uv(4 * (i - 1) + j) = tmp_uv(j)
      enddo
    enddo
  endif

  return
end subroutine tandem2

subroutine recfil2(x, y, n, h, nml, uv1)
  implicit none
  integer, intent(IN) :: n, nml
  real*8, intent(IN) :: x(n), h(4)
  real*8, intent(OUT) :: y(n)
  real*8, intent(INOUT) :: uv1(4)

  integer :: j, jd, i
  real*8 :: a, aa, b, bb, u1, u2, u3, v1, v2, v3

  if(nml .ge. 0) then
    j = 1
    jd = 1
  else
    j = n
    jd = -1
  endif

  a = h(1)
  aa = h(2)
  b = h(3)
  bb = h(4)
  u1 = uv1(1)
  u2 = uv1(2)
  v1 = uv1(3)
  v2 = uv1(4)

  do i = 1, n
    u3 = u2
    u2 = u1
    u1 = x(j)
    v3 = v2
    v2 = v1
    v1 = u1 + a * u2 + aa * u3 - b * v2 - bb * v3
    y(j) = v1
    j = j + jd
  enddo

  uv1(1) = u1
  uv1(2) = u2
  uv1(3) = v1
  uv1(4) = v2

  return
end subroutine recfil2


!  compile using "gfortran -xf95-cpp-input"
!    to invoke the preprocessor

PROGRAM main

use emombm
IMPLICIT NONE
	INTEGER i, ice
	REAL*8, DIMENSION(J) :: Quold, Qlold, Tsold, Qunew, Qlnew, Tsnew
	REAL*8 :: Taveold, Tavenew
	REAL*8, DIMENSION(J+1) :: Uu,Ul,tau

	call emombm_setup()

	print *, ' '
	print *, 'Running the EMomBM once'
	print *, ' '

	if (.NOT. readInputFile ) then
		!  fixed initial condition
		Quold = dble(2.0)*f0/sqrt(2.)*sin(phiq)
		Qlold = Quold
		Taveold = 11.
		Tsold = 40.-40.*2./pi*phiq
	else
		!  get initial condition from a file
		print *, 'Loading initial conditions from file ', inputfilename
		open(unit=10,file=inputfilename)
		read(unit=10,fmt=*) Quold,Qlold
		read(unit=10,fmt=*) Taveold
		read(unit=10,fmt=*) Tsold
		close(unit=10)
	end if

	!  main time loop
time:	DO i=1,numsteps
			call timestep_emombm(Quold,Qlold,Taveold,Tsold,Qunew,Qlnew,Tavenew,Tsnew,ice)
			Quold = Qunew
			Qlold = Qlnew
			Taveold = Tavenew
			Tsold = Tsnew
			!PRINT *, ice
		END DO time

	! final winds
	CALL solveU(Quold,Qlold,Uu,Ul,J)
	tau = eps*(3*Ul - Uu)/2

	100 format(F14.8)
	101 format(E20.10)
	open(unit=10,file='output.dat')
	write(unit=10,fmt=101) Qunew,Qlnew
	write(unit=10,fmt=100) Tavenew
	write(unit=10,fmt=100) Tsnew
	write(unit=10,fmt=101) Uu,Ul,tau
	close(unit=10)
	print *, 'Results saved to file output.dat'
END PROGRAM main


      REAL FUNCTION R1MACH(I)

c        Single-precision machine constants

c  Assume floating-point numbers are represented in the t-digit,
c  base-b form

c         sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) )

c  where 0.le.x(i).lt.b  for  i = 1,...,t,
c  0.lt.x(1), and  emin.LE.e.LE.emax.  then

c  R1MACH(1) = b**(emin-1), the smallest positive magnitude
c              (use TINY(R) in Fortran 90, where R is a single
c              precision variable)

c  R1MACH(2) = b**emax*(1 - b**(-t)), the largest magnitude
c              (use HUGE(R) in Fortran 90, where R is a single
c              precision variable))

c  R1MACH(3) = b**(-t), the smallest relative spacing.

c  R1MACH(4) = b**(1-t), the largest relative spacing.  i.e.,
c              smallest positive eps such that  1+eps .ne. 1
c              (use EPSILON(R) in Fortran 90, where R is a single
c              precision variable))

c  R1MACH(5) = LOG10(b)

c  Reference: Fox P.A., Hall A.D., Schryer N.L.,'Framework For A
c               Portable Library', ACM Transactions On Mathematical
c               Software, Vol. 4, No. 2, June 1978, pp. 177-188.

c  By default, returns values appropriate for a computer with IEEE
c  arithmetic.  This is an abbreviated version of a routine widely
c  used for 20+ years by numerical analysts.  Most of the values in
c  the original version pertain to computers which went to computer
c  heaven years ago and are of little if any interest.
c
c  If the values herein do not work for any reason, just look in
c  your Fortran manual for the correct values (usually in the part
c  discussing representations of numbers) and insert them. The exact
c  values are not that important; they can be a factor of 2-3 off
c  without causing any harm.

c  Only I = 1,2,4 is actually used by DISORT.

c  This routine is superseded in Fortran-90 by the intrinsic numeric
c  inquiry functions HUGE(1.0), TINY(1.0), and EPSILON(1.0).

c  The original version can be found on NetLib (search by name):
c      http://www.netlib.org/
c ====================================================================

      INTEGER I
c      EXTERNAL  ERRMSG

      IF( I.EQ.1 )  THEN
c         R1MACH = 1.2E-38
        R1MACH = TINY(1.0)
      ELSE IF( I.EQ.2 )  THEN
c         R1MACH = 3.4E+38
        R1MACH = HUGE(1.0)
      ELSE IF( I.EQ.4 )  THEN
c         R1MACH = 1.2E-07
        R1MACH = EPSILON(1.0)
      ELSE
c         CALL ERRMSG( 'R1MACH--argument incorrect', .TRUE.)
         print *,"Error! Invalid input to r1mach"
         print *,"I=",I
         stop
      END IF

      RETURN
      END


program qa6
! (LICENSE:Public Domain)
   use m_calcomp
   dimension totx(10),toty(10),am(10,10),cv(10)
   !
   kin=50
   call make_c_qa6()
   open(unit=kin,file='qa6.dat')
   !
   read (kin,'(3I6)')nx,ny,ncv
   write (6,900)nx,ny,ncv
   read (kin,810)(totx(i),i=1,nx)
   write (6,910)(totx(i),i=1,nx)
   read (kin,810)(toty(i),i=1,ny)
   write (6,920)(toty(i),i=1,ny)
   write (6,'("0AM")')
   !
   do j=1,ny
      read (kin,810)(am(i,j),i=1,nx)
      write (6,940)(am(i,j),i=1,nx)
   enddo
   !
   read (kin,810)(cv(i),i=1,ncv)
   write (6,950)(cv(i),i=1,ncv)
   ! plotting
   call plots(0.0,8.5,0.0,11.0)
   call plot(0.,1.,-3)
   call cntour(am,nx,ny,totx,toty,3.0,cv,ncv,.true.,10)
   call plot(0.0,0.0,999)
810 format(8F6.1)
900 format('1','NX =',I2,'NY =',I2,'NCV =',I2)
910 format('0','TOTX',/,(' ',5X,10F10.1))
920 format('0','TOTY',/(' ',5X,10F10.1))
940 format('0',5X,10F10.1)
950 format('0','CV',/,(' ',10F10.1))
   stop
contains
   subroutine make_c_qa6()
      ! create test input file
      integer,parameter :: io=40
      open(unit=io,file='qa6.dat')
      write(io,'(a)')'     6     7     8'
      write(io,'(a)')'0.    3.    6.    8.    10.   12.'
      write(io,'(a)')'0.    2.    3.    5.    7.    8.    10.'
      write(io,'(a)')'0.    0.    0.    0.    0.    0.'
      write(io,'(a)')'20.   25.   29.   27.   23.   20.'
      write(io,'(a)')'30.   39.   48.   42.   36.   30.'
      write(io,'(a)')'50.   62.   94.   69.   57.   50.'
      write(io,'(a)')'70.   79.   89.   82.   76.   70.'
      write(io,'(a)')'80.   84.   88.   86.   83.   80.'
      write(io,'(a)')'100.  100.  100.  100.  100.  100.'
      write(io,'(a)')'90.   80.   70.   60.   50.   40.   30.   20.'
      close(unit=io)
   end subroutine make_c_qa6
end program qa6


!! ---------------------------------------------------------------*

!     Find the energetic terms from R

!     Revised 6-22-04

      subroutine r_to_erg(R,NT,N,ECOM,EBEND)

      real(dp) R(3,NT)  ! Bead positions
      real(dp) U(3,N-1) ! Tangent
      real(dp) B(N-1)   ! Bond length
      integer N,NT              ! Number of beads
      integer I
      real(dp) KAP,EPS  ! DNA mat props
      real(dp) L0       ! Equilibrium
                                ! bead separation
      real(dp) doT      ! Dot product

!     Variables in the tube interaction

      real(dp) LHC      ! Length of HC int
      real(dp) VHC      ! HC strength
      real(dp) RAD      ! Radius of int
      real(dp) SIGP     ! Poly diameter of int
      real(dp) forCE

!     Energy variables

      real(dp) ECOM     ! Compression energy
      real(dp) EBEND    ! Bending energy
      real(dp) EEX      ! External energy
      real(dp) EPONP    ! Poly energy

!     Setup the properties

      open (unit = 5, file = 'input/input')
      read (unit = 5, fmt = '(4(/))')
      read (unit = 5, fmt = *) KAP
      read (unit = 5, fmt = '(2(/))')
      read (unit = 5, fmt = *) EPS
      read (unit = 5, fmt = '(2(/))')
      read (unit = 5, fmt = *) L0
      close(5)

!     Setup the necessary quantities

      do 10 I = 1,(N-1)
         B(I) = sqrt((R(1,I + 1)-R(1,I))**2. + (R(2,I + 1)-R(2,I))**2. + (R(3,I + 1)-R(3,I))**2.)
         U(1,I) = (R(1,I + 1)-R(1,I))/B(I)
         U(2,I) = (R(2,I + 1)-R(2,I))/B(I)
         U(3,I) = (R(3,I + 1)-R(3,I))/B(I)
 10   continue

!     Calculate the energetic contributions

      ECOM = 0.
      do 30 I = 1,(N-1)
         ECOM = ECOM + (B(I)-L0)**2.
 30   continue
      ECOM = 0.5*KAP*ECOM

      EBEND = 0.
      do 40 I = 1,(N-2)
         doT = U(1,I + 1)*U(1,I) + U(2,I + 1)*U(2,I) + U(3,I + 1)*U(3,I)
         EBEND = EBEND + 1.-doT
 40   continue
      EBEND = EPS*EBEND

!     call energy_ex(EEX,R,N,LHC,VHC,RAD)
!     call energy_ponp(EPONP,R,N,LB,LHC,VHC,SIGP)

      RETURN
      END

!---------------------------------------------------------------*


! Simple program to return the speed of sound
program speed_calc

  use set_precision,   only : dp
  use fluid_constants, only : gamma, set_fluid_constants

  real(dp) :: rho, p, a

  interface
    function speed_of_sound(p,rho)
      use set_precision, only : dp
      real(dp), intent(in) :: p, rho
      real(dp)             :: speed_of_sound
    end function speed_of_sound
  end interface

  continue

  ! Set up fluid constants
  gamma = 1.4_dp
  call set_fluid_constants

  print*, "Enter the pressure:"
  read(*,*) p

  print*, "Enter the density:"
  read(*,*) rho

  print*, speed_of_sound(p,rho)

end program speed_calc

include 'speed_of_sound.f90'


C/MEMBR ADD NAME=MAGIC,SSI=0
      subroutine magic(a,lda,n)
c!purpose
c     algorithms for magic squares taken from
c        mathematical recreations and essays, 12th ed.,
c        by w. w. rouse ball and h. s. m. coxeter
c!calling sequence
c     subroutine magic(a,lda,n)
c     double precision a(lda,n)
c     integer lda,n
c!
      double precision a(lda,n),t
c
      if (mod(n,4) .eq. 0) go to 100
      if (mod(n,2) .eq. 0) m = n/2
      if (mod(n,2) .ne. 0) m = n
c
c     odd order or upper corner of even order
c
      do 20 j = 1,m
         do 10 i = 1,m
            a(i,j) = 0
   10    continue
   20 continue
      i = 1
      j = (m+1)/2
      mm = m*m
      do 40 k = 1, mm
         a(i,j) = k
         i1 = i-1
         j1 = j+1
         if(i1.lt.1) i1 = m
         if(j1.gt.m) j1 = 1
         if(int(a(i1,j1)).eq.0) go to 30
            i1 = i+1
            j1 = j
   30    i = i1
         j = j1
   40 continue
      if (mod(n,2) .ne. 0) return
c
c     rest of even order
c
      t = m*m
      do 60 i = 1, m
         do 50 j = 1, m
            im = i+m
            jm = j+m
            a(i,jm) = a(i,j) + 2*t
            a(im,j) = a(i,j) + 3*t
            a(im,jm) = a(i,j) + t
   50    continue
   60 continue
      m1 = (m-1)/2
      if (m1.eq.0) return
      do 70 j = 1, m1
         call dswap(m,a(1,j),1,a(m+1,j),1)
   70 continue
      m1 = (m+1)/2
      m2 = m1 + m
      call dswap(1,a(m1,1),1,a(m2,1),1)
      call dswap(1,a(m1,m1),1,a(m2,m1),1)
      m1 = n+1-(m-3)/2
      if(m1.gt.n) return
      do 80 j = m1, n
         call dswap(m,a(1,j),1,a(m+1,j),1)
   80 continue
      return
c
c     double even order
c
  100 k = 1
      do 120 i = 1, n
         do 110 j = 1, n
            a(i,j) = k
            if (mod(i,4)/2 .eq. mod(j,4)/2) a(i,j) = n*n+1 - k
            k = k+1
  110    continue
  120 continue
      return
      end


program genspec
    use sta2dfft
    use constants, only : pi, twopi, f14, f12, zero, one, two
    use netcdf_reader
    use netcdf_writer
    implicit none

    ! Grid dimensions:
    integer :: nx, nz

    ! Width and height of the domain:
    double precision :: extent(2)

    double precision :: dx, dz

    ! Array to contain data:
    double precision, allocatable :: pp(:, :)

    ! Its Fourier transform:
    double precision, allocatable :: ss(:, :)

    ! The spectrum:
    double precision, allocatable :: spec(:)

    ! x and z wavenumbers:
    double precision, allocatable :: rkx(:), hrkx(:), rkz(:)

    ! Generic arrays needed for the FFTs:
    double precision, allocatable :: xtrig(:), ztrig(:)
    integer :: xfactors(5), zfactors(5)

    ! Wavenumber magnitude used for the spectrum:
    integer, allocatable :: kmag(:, :)

    ! Other work variables:
    double precision :: scx, rkxmax, scz, rkzmax, delk, delki, snorm
    integer :: kxc, kmax, kx, kz, k

    character(len=512) :: filename
    character(len=64)  :: dset
    integer            :: step

    call parse_command_line

    call get_domain

    dx = extent(1) / dble(nx)
    dz = extent(2) / dble(nz)

    print *, 'Field: ' // trim(dset)
    print '(a23, i5, a6, i5)', 'Grid dimensions: nx = ', nx, ' nz = ', nz

    call alloc_arrays

    ! read data into array pp:
    call read_data

    !---------------------------------------------------------------------
    ! Set up FFTs:
    call init2dfft(nx, nz, extent(1), extent(2), xfactors, zfactors, xtrig, ztrig, hrkx, rkz)

    !Define x wavenumbers:
    rkx(0) = zero
    do kx = 1, nx / 2 - 1
        kxc = nx - kx
        rkx(kx ) = hrkx(2 * kx)
        rkx(kxc) = hrkx(2 * kx)
    enddo
    rkx(nx / 2) = hrkx(nx)

    !Initialise arrays for computing the spectrum:
    scx = twopi / extent(1)
    rkxmax = scx * dble(nx / 2)
    scz = pi / extent(2)
    rkzmax = scz * dble(nz)
    delk = sqrt(scx ** 2 + scz **2)
    delki = one / delk
    kmax = nint(dsqrt(rkxmax ** 2 + rkzmax ** 2) * delki)
    do kz = 1, nz
        do kx = 0, nx - 1
            kmag(kx, kz) = nint(dsqrt(rkx(kx) ** 2 + rkz(kz) ** 2) * delki)
        enddo
    enddo
    do kx = 0, nx - 1
        kmag(kx, 0) = nint(rkx(kx) * delki)
    enddo

    !Compute spectrum multiplication factor (snorm) so that the sum
    !of the spectrum is equal to the L2 norm of the original field:
    snorm = two * dx * dz * delki

    !---------------------------------------------------------------------
    !Compute spectrum:

    !Transform data in pp to spectral space:
    call ptospc_fc(nx, nz, pp, ss, xfactors, zfactors, xtrig, ztrig)

    do k = 0, kmax
        spec(k) = zero
    enddo

    !x and y-independent mode:
    k = kmag(0, 0)
    spec(k) = spec(k) + f14 * ss(0, 0) ** 2

    !y-independent mode:
    do kx = 1, nx - 1
        k = kmag(kx, 0)
        spec(k) = spec(k) + f12 * ss(kx, 0) ** 2
    enddo

    !x-independent mode:
    do kz = 1, nz
        k = kmag(0, kz)
        spec(k) = spec(k) + f12 * ss(0, kz) ** 2
    enddo

    !All other modes:
    do kz = 1, nz
        do kx = 1, nx - 1
            k = kmag(kx, kz)
            spec(k) = spec(k) + ss(kx, kz) ** 2
        enddo
    enddo

    !Normalise:
    spec(0:kmax) = snorm * spec(0:kmax)

    !---------------------------------------------------------------------
    !Write spectrum contained in spec(k):
    call write_spectrum

    call dealloc_arrays

    contains

        subroutine get_domain
            integer          :: ncid
            double precision :: lower(2)
            integer          :: ncells(2)
            ! read domain dimensions
            call open_netcdf_file(trim(filename), NF90_NOWRITE, ncid)
            call get_netcdf_box(ncid, lower, extent, ncells)
            nx = ncells(1)
            nz = ncells(2)
            call close_netcdf_file(ncid)
        end subroutine get_domain

        subroutine alloc_arrays
            allocate(pp(0:nz, 0:nx - 1))
            allocate(ss(0:nx - 1, 0:nz))
            allocate(spec(0:max(nx, nz)))
            allocate(rkx(0:nx - 1))
            allocate(hrkx(nx))
            allocate(rkz(nz))
            allocate(xtrig(2 * nx))
            allocate(ztrig(2 * nz))
            allocate(kmag(0:nx - 1, 0:nz))
        end subroutine alloc_arrays

        subroutine dealloc_arrays
            deallocate(pp)
            deallocate(ss)
            deallocate(spec)
            deallocate(rkx)
            deallocate(hrkx)
            deallocate(rkz)
            deallocate(xtrig)
            deallocate(ztrig)
            deallocate(kmag)
        end subroutine dealloc_arrays

        subroutine read_data
            double precision :: buffer(nz+1, nx)
            integer          :: ncid, cnt(3), start(3), n_steps

            call open_netcdf_file(trim(filename), NF90_NOWRITE, ncid)

            call get_num_steps(ncid, n_steps)

            if (step > n_steps) then
                print *, "Error: NetCDF file has not enough records."
                stop
            endif

            cnt  =  (/ nz+1, nx, 1    /)
            start = (/ 1,    1,  step /)

            if (has_dataset(ncid, trim(dset))) then
                call read_netcdf_dataset(ncid, trim(dset), buffer, &
                                         start=start, cnt=cnt)
            else
                print *, "Error: No dataset '" // trim(dset) // "' in the file."
                stop
            endif

            call close_netcdf_file(ncid)
        end subroutine read_data

        subroutine write_spectrum
            logical                   :: exists = .false.
            character(:), allocatable :: fname
            integer                   :: pos

            ! 1 October 2021
            ! https://stackoverflow.com/questions/36731707/fortran-how-to-remove-file-extension-from-character
            pos = scan(trim(filename), '.', back=.true.)

            if (pos > 0) then
                fname = filename(1:pos-1) // '_spectrum.asc'
            else
                print *, "Error in reading the filename. File extension not found."
            endif

            inquire(file=fname, exist=exists)
            if (exists) then
                print *, "Error: File '" // trim(fname) // "' already exists."
                stop
            else
                open(unit=1235, file=fname, status='replace')
                write(1235, *) '# The power spectrum of the ' // trim(dset) // ' field.'
                write(1235, *) '# The first column is the wavenumber, the second column the spectrum.'
                write(1235, *) '#         k   P(k)'
            endif

            do k = 1, kmax
                write(1235, *) k * delk, spec(k)
            enddo

            close(1235)

        end subroutine write_spectrum

        ! Get the file name provided via the command line
        subroutine parse_command_line
            integer            :: i, stat
            character(len=512) :: arg
            logical            :: exists

            step = -1
            filename = ''
            dset = 'total buoyancy'
            i = 0
            do
                call get_command_argument(i, arg)
                if (len_trim(arg) == 0) then
                    exit
                endif

                if (arg == '--filename') then
                    i = i + 1
                    call get_command_argument(i, arg)
                    filename = trim(arg)
                else if (arg == '--dset') then
                    i = i + 1
                    call get_command_argument(i, arg)
                    dset = trim(arg)
                else if (arg == '--step') then
                    i = i + 1
                    call get_command_argument(i, arg)

                    ! 1 October 2021
                    ! https://stackoverflow.com/questions/24071722/converting-a-string-to-an-integer-in-fortran-90
                    read(arg, *, iostat=stat)  step
                    if (stat .ne. 0) then
                        print *, 'Error conversion failed.'
                        stop
                    endif
                else if (arg == '--help') then
                    print *, 'This program computes the power spectrum and writes it to file.'
                    print *, 'An EPIC field output must be provided with the step number to analyse.'
                    print *, 'Run code with "genspec --filename [field file]" --step [step number] --dset [dataset]'
                    stop
                endif
                i = i+1
            enddo

            if ((filename == '') .or. (step == -1) ) then
                print *, 'No file or step provided. Run code with "genspec --help"'
                stop
            endif

            ! check if correct file is passed
            stat = index(trim(filename), '_fields.nc', back=.true.)
            if (stat == 0) then
                print *, "Error: No EPIC field output file provided."
                stop
            endif

            ! check if file exsits
            inquire(file=trim(filename), exist=exists)
            if (.not. exists) then
                print *, "Error: File '" // trim(filename) // "' does not exist."
                stop
            endif
        end subroutine parse_command_line

end program genspec


Subroutine gradun(ix, iy, iz, gradxn, gradyn, gradzn)
  Parameter (maxx=20, maxz=24)
  Parameter (rho0=0.168)
  Common /dd/rho(-maxx:maxx, -maxx:maxx, -maxz:maxz), rhop(-maxx:maxx, -maxx:maxx, -maxz:maxz), rhon(-maxx:maxx, -maxx:maxx, -maxz:maxz)
  Common /ss/inout(20)
  Save
  rxplus = rhon(ix+1, iy, iz)/rho0
  rxmins = rhon(ix-1, iy, iz)/rho0
  ryplus = rhon(ix, iy+1, iz)/rho0
  rymins = rhon(ix, iy-1, iz)/rho0
  rzplus = rhon(ix, iy, iz+1)/rho0
  rzmins = rhon(ix, iy, iz-1)/rho0
  gradxn = (rxplus-rxmins)/2.
  gradyn = (ryplus-rymins)/2.
  gradzn = (rzplus-rzmins)/2.
  Return
End Subroutine gradun


c
c-----------------------------------------------------------------------
c
      subroutine dcube(t,f,fp,ta,fa,fpa,tlower,tupper)
c
c
c --- arguments
c
      double precision sign,den,anum,t,f,fp,ta,fa,fpa,tlower,tupper
c
c --- variables locales
c
      double precision z1,b,discri
c
c           Using f and fp at t and ta, computes new t by cubic formula
c           safeguarded inside [tlower,tupper].
c
      z1=fp+fpa-3.d0*(fa-f)/(ta-t)
      b=z1+fp
c
c              first compute the discriminant (without overflow)
c
      if (dabs(z1).le.1.d0) then
          discri=z1*z1-fp*fpa
        else
          discri=fp/z1
          discri=discri*fpa
          discri=z1-discri
          if (z1.ge.0.d0 .and. discri.ge.0.d0) then
              discri=dsqrt(z1)*dsqrt(discri)
              go to 120
          endif
          if (z1.le.0.d0 .and. discri.le.0.d0) then
              discri=dsqrt(-z1)*dsqrt(-discri)
              go to 120
          endif
          discri=-1.d0
      endif
      if (discri.lt.0.d0) then
          if (fp.lt.0.d0) t=tupper
          if (fp.ge.0.d0) t=tlower
          go to 900
      endif
c
c  discriminant nonnegative, compute solution (without overflow)
c
      discri=dsqrt(discri)
  120 if (t-ta.lt.0.d0) discri=-discri
      sign=(t-ta)/dabs(t-ta)
      if (b*sign.gt.0.d+0) then
          t=t+fp*(ta-t)/(b+discri)
        else
          den=z1+b+fpa
          anum=b-discri
          if (dabs((t-ta)*anum).lt.(tupper-tlower)*dabs(den)) then
              t=t+anum*(ta-t)/den
            else
              t=tupper
          endif
      endif
  900 t=dmax1(t,tlower)
      t=dmin1(t,tupper)
      return
      end


      FUNCTION ran1( idum )
c     Returns a uniform random deviate between 0.0 and 1.0.  Set IDUM
c to any negative value to initialize or reinitialize the sequence.
c     From "Numerical Recipes" by Press, Flannery, Teulolsky, Vetterling
c
      PARAMETER ( m1 = 259200, ia1 = 7141, ic1 = 54773, rm1 = 1./m1 )
      PARAMETER ( m2 = 134456, ia2 = 8191, ic2 = 28411, rm2 = 1./m2 )
      PARAMETER ( m3 = 243000, ia3 = 4561, ic3 = 51349 )
      DIMENSION r(97)
      SAVE
      DATA iff/0/
c        initialize on first call even if IDUM is not negative
      IF( idum .LT. 0 .OR. iff .EQ. 0 ) THEN
          iff = 1
          ix1 = MOD( ic1-idum, m1 )                                     ! seed the first routine
          ix1 = MOD( ia1*ix1+ic1, m1 )
          ix2 = MOD( ix1, m2 )                                          ! and use it to seed the second
          ix1 = MOD( ia1*ix1+ic1, m1 )
          ix3 = MOD( ix1, m3 )                                          ! and third routines.
          DO 100 j = 1, 97                                              ! fill the table with sequential uniform
             ix1 = MOD( ia1*ix1+ic1, m1 )                               ! deviates generated by the first two routines.
             ix2 = MOD( ia2*ix2+ic2, m2 )
             r(j) = ( FLOAT(ix1) + FLOAT(ix2) * rm2 ) * rm1             ! low and high-order pieces combine here
  100     CONTINUE
          idum = 1
      ENDIF
      ix1 = MOD( ia1*ix1+ic1, m1 )                                      ! except when initializing, this is where we start.
      ix2 = MOD( ia2*ix2+ic2, m2 )                                      ! generate the next number for each sequence.
      ix3 = MOD( ia3*ix3+ic3, m3 )
      j = 1 + (97*ix3) / m3                                             ! use the third sequence to get an integer between 1 and 97
      IF( j .GT. 97 .OR. j .LT. 1 ) THEN
          PRINT *,' ***  ERROR  *** function ran1 blew up.'
          STOP
      ENDIF
      ran1 = r(j)                                                       ! return that table entry
      r(j) = ( FLOAT(ix1) + FLOAT(ix2) * rm2 ) * rm1                    ! and refill it
      RETURN
      END