c  This file contains the Laplace FMM wrappers
c
c  The laplace FMM evaluates the following potential
c  and its gradient
c
c     u(x) = \sum_{j=1}^{N} c_{j}/|x-x_{j}| - v_{j}.\nabla (1/|x-x_{j}|)
c
c  Here x_{j} are the source locations, c_{j} are the charge strengths,
c  v_{j} are the dipole strengths. We refer to the collection of
c  $x$ at which the potential and its gradient are evaluated as the
c  evaluation points
c
c  The subroutine names take the following form:
c    lfmm3d_<eval-pts>_<int-ker>_<out>
c
c      <eval-pts>: evaluation points (sources/targets/sources+targets)
c        s: source locations
c        t: target locations
c        st: source and target locations
c
c      <int-ker>: kernel of interaction (charges/dipoles/both)
c        c: charges
c        d: dipoles
c        cd: charges+dipoles
c
c      <out>: flag for potential/potential+gradient
c        p: potentials
c        g: potentials+gradients
c        h: potentials+gradients+hessians
c
c  The wrappers are:
c
c
c  -lfmm3d_s_c_p
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_c_g
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_s_c_h
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_s_d_p
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_d_g
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_s_d_h
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_s_cd_p
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_s_cd_g
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_s_cd_h
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_t_c_p
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_c_g
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_c_h
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_t_d_p
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_d_g
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_d_h
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_t_cd_p
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_t_cd_g
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_t_cd_h
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_st_c_p
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_c_g
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_c_h
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_st_d_p
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_d_g
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_d_h
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c  -lfmm3d_st_cd_p
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -lfmm3d_st_cd_g
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -lfmm3d_st_cd_h
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential, Gradient and Hessians
c-------------------------------------
c

      subroutine lfmm3d_s_c_p(eps,nsource,source,
     1    charge,pot,ier)
      implicit none
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot
cf2py  intent(out) ier

c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      double precision eps
      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)

      double precision dipvec(3,1)

      double precision pot(nsource)

      double precision pottarg(1)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_c_g(eps,nsource,source,
     1    charge,pot,grad,ier)
      implicit none
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot,grad
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)

      double precision dipvec(3,1)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_s_c_h(eps,nsource,source,
     1    charge,pot,grad,hess,ier)
      implicit none
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c--------------------------------
c
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)

      double precision dipvec(3,1)

      double precision pot(nsource),grad(3,nsource),hess(6,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_d_p(eps,nsource,source,
     1    dipvec,pot,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource)
      double precision pottarg(1)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_d_g(eps,nsource,source,
     1    dipvec,pot,grad,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot,grad
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_s_d_h(eps,nsource,source,
     1    dipvec,pot,grad,hess,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource),hess(6,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c

      subroutine lfmm3d_s_cd_p(eps,nsource,source,
     1    charge,dipvec,pot,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource)
      double precision pottarg(1)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c
c
c
c
c

      subroutine lfmm3d_s_cd_g(eps,nsource,source,
     1    charge,dipvec,pot,grad,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot,grad
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c
c

      subroutine lfmm3d_s_cd_h(eps,nsource,source,
     1    charge,dipvec,pot,grad,hess,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source locations $x=x_{j}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,1)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource),hess(6,nsource)
      double precision pottarg(1),gradtarg(3,1)

      double precision hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 0

      ntarg = 0
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c

      subroutine lfmm3d_t_c_p(eps,nsource,source,
     1    charge,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(1)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_c_g(eps,nsource,source,
     1    charge,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_c_h(eps,nsource,source,
     1    charge,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)
      double precision hesstarg(6,ntarg)

      double precision hess(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c

      subroutine lfmm3d_t_d_p(eps,nsource,source,
     1    dipvec,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(1)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_t_d_g(eps,nsource,source,
     1    dipvec,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_d_h(eps,nsource,source,
     1    dipvec,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)
      double precision hesstarg(6,ntarg)

      double precision hess(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_t_cd_p(eps,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(1)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_cd_g(eps,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_t_cd_h(eps,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the target locations $x=t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(1),grad(3,1)
      double precision pottarg(ntarg),gradtarg(3,ntarg)
      double precision hesstarg(6,ntarg)

      double precision hess(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
      subroutine lfmm3d_st_c_p(eps,nsource,source,
     1    charge,pot,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(nsource)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_c_g(eps,nsource,source,
     1    charge,pot,grad,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_c_h(eps,nsource,source,
     1    charge,pot,grad,hess,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|}
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,1)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6,nsource),hesstarg(6,ntarg)

      nd = 1
      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_d_p(eps,nsource,source,
     1    dipvec,pot,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_d_g(eps,nsource,source,
     1    dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_d_h(eps,nsource,source,
     1    dipvec,pot,grad,hess,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = -\sum_{j=1}^{N} v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(1)

      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6,nsource),hesstarg(6,ntarg)

      nd = 1
      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c

      subroutine lfmm3d_st_cd_p(eps,nsource,source,
     1    charge,dipvec,pot,ntarg,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource)
      double precision pottarg(ntarg)

      double precision grad(3),gradtarg(3)
      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c

      subroutine lfmm3d_st_cd_g(eps,nsource,source,
     1    charge,dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
cc    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6),hesstarg(6)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c
c

      subroutine lfmm3d_st_cd_h(eps,nsource,source,
     1    charge,dipvec,pot,grad,hess,ntarg,targ,pottarg,
     2    gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad,hess
cf2py  intent(out) pottarg,gradtarg,hesstarg
cf2py  intent(out) ier
c-------------------------------------
c
c  This subroutine evaluates the potential, its gradient,
c  and its hessian
c      u(x) = \sum_{j=1}^{N} c_{j} \frac{1}{\|x-x_{j}\|} -
c            v_{j} \cdot \nabla \left(
c            \frac{1}{\|x-x_{j}\|}\right)
c
c  at the source and target locations $x=x_{j},t_{i}$.
c  When $x=x_{j}$, the term corresponding to $x_{j}$ is
c  dropped from the sum.
c
c  Input arguments:
c
c    -    eps: double precision
c          precision requested
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double precision(nsource)
c          Charge strengths, $c_{j}$
c    -    dipvec: double precision(3,nsource)
c          Dipole strengths, $v_{j}$
c    -    ntarg: integer
c          Number of targets
c    -    targ: double precision(3,ntarg)
c          Target locations, $t_{i}$
c
c
c  Output arguments:
c    -    pot: double precision(nsource)
c          Potential at source locations, $u(x_{j})$
c    -    grad: double precision(3,nsource)
c          Gradient at source locations, $\nabla u(x_{j})$
c    -    hess: double precision(6,nsource)
c          Hessian at source locations, $\nabla^2 u(x_{j})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    pottarg: double precision(ntarg)
c          Potential at target locations, $u(t_{i})$
c    -    gradtarg: double precision(3,ntarg)
c          Gradient at target locations, $\nabla u(t_{i})$
c    -    hesstarg: double precision(6,ntarg)
c          Hessian at target locations, $\nabla^2 u(t_{i})$
c          Hessian is ordered as
c          $u_{xx},u_{yy},u_{zz},u_{xy},u_{xz},u_{yz}$
c    -    ier: integer
c          error flag
c           * ier = 0, for normal execution
c           * ier = 4/8, failed to allocate memory in fmm routine
c
c--------------------------------
c
      implicit none
      double precision eps

      integer nsource,ntarg,ifcharge,ifdipole,ifpgh,ifpghtarg
      integer nd,ier,iper

      double precision source(3,nsource),targ(3,ntarg)
      double precision charge(nsource)
      double precision dipvec(3,nsource)

      double precision pot(nsource),grad(3,nsource)
      double precision pottarg(ntarg),gradtarg(3,ntarg)

      double precision hess(6,nsource),hesstarg(6,ntarg)

      nd = 1
      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3
      ier = 0

      call lfmm3d(nd,eps,nsource,source,ifcharge,charge,
     1      ifdipole,dipvec,iper,ifpgh,pot,grad,hess,ntarg,targ,
     2      ifpghtarg,pottarg,gradtarg,hesstarg,ier)

      return
      end
c
c
c
c
c


!*==dgtsv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DGTSV computes the solution to system of linear equations A * X = B for GT matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGTSV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDB, N, NRHS
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGTSV  solves the equation
!>
!>    A*X = B,
!>
!> where A is an n by n tridiagonal matrix, by Gaussian elimination with
!> partial pivoting.
!>
!> Note that the equation  A**T*X = B  may be solved by interchanging the
!> order of the arguments DU and DL.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] DL
!> \verbatim
!>          DL is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, DL must contain the (n-1) sub-diagonal elements of
!>          A.
!>
!>          On exit, DL is overwritten by the (n-2) elements of the
!>          second super-diagonal of the upper triangular matrix U from
!>          the LU factorization of A, in DL(1), ..., DL(n-2).
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, D must contain the diagonal elements of A.
!>
!>          On exit, D is overwritten by the n diagonal elements of U.
!> \endverbatim
!>
!> \param[in,out] DU
!> \verbatim
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, DU must contain the (n-1) super-diagonal elements
!>          of A.
!>
!>          On exit, DU is overwritten by the (n-1) elements of the first
!>          super-diagonal of U.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the N by NRHS matrix of right hand side matrix B.
!>          On exit, if INFO = 0, the N by NRHS solution matrix X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = i, U(i,i) is exactly zero, and the solution
!>               has not been computed.  The factorization has not been
!>               completed unless i = N.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleGTsolve
!
!  =====================================================================
      SUBROUTINE DGTSV(N,Nrhs,Dl,D,Du,B,Ldb,Info)
      IMPLICIT NONE
!*--DGTSV131
!
!  -- LAPACK driver 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 ..
      INTEGER Info , Ldb , N , Nrhs
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION B(Ldb,*) , D(*) , Dl(*) , Du(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , j
      DOUBLE PRECISION fact , temp
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Executable Statements ..
!
      Info = 0
      IF ( N<0 ) THEN
         Info = -1
      ELSEIF ( Nrhs<0 ) THEN
         Info = -2
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGTSV ',-Info)
         RETURN
      ENDIF
!
      IF ( N==0 ) RETURN
!
      IF ( Nrhs==1 ) THEN
         DO i = 1 , N - 2
            IF ( ABS(D(i))>=ABS(Dl(i)) ) THEN
!
!              No row interchange required
!
               IF ( D(i)/=ZERO ) THEN
                  fact = Dl(i)/D(i)
                  D(i+1) = D(i+1) - fact*Du(i)
                  B(i+1,1) = B(i+1,1) - fact*B(i,1)
               ELSE
                  Info = i
                  RETURN
               ENDIF
               Dl(i) = ZERO
            ELSE
!
!              Interchange rows I and I+1
!
               fact = D(i)/Dl(i)
               D(i) = Dl(i)
               temp = D(i+1)
               D(i+1) = Du(i) - fact*temp
               Dl(i) = Du(i+1)
               Du(i+1) = -fact*Dl(i)
               Du(i) = temp
               temp = B(i,1)
               B(i,1) = B(i+1,1)
               B(i+1,1) = temp - fact*B(i+1,1)
            ENDIF
         ENDDO
         IF ( N>1 ) THEN
            i = N - 1
            IF ( ABS(D(i))<ABS(Dl(i)) ) THEN
               fact = D(i)/Dl(i)
               D(i) = Dl(i)
               temp = D(i+1)
               D(i+1) = Du(i) - fact*temp
               Du(i) = temp
               temp = B(i,1)
               B(i,1) = B(i+1,1)
               B(i+1,1) = temp - fact*B(i+1,1)
            ELSEIF ( D(i)/=ZERO ) THEN
               fact = Dl(i)/D(i)
               D(i+1) = D(i+1) - fact*Du(i)
               B(i+1,1) = B(i+1,1) - fact*B(i,1)
            ELSE
               Info = i
               RETURN
            ENDIF
         ENDIF
         IF ( D(N)==ZERO ) THEN
            Info = N
            RETURN
         ENDIF
      ELSE
         DO i = 1 , N - 2
            IF ( ABS(D(i))>=ABS(Dl(i)) ) THEN
!
!              No row interchange required
!
               IF ( D(i)/=ZERO ) THEN
                  fact = Dl(i)/D(i)
                  D(i+1) = D(i+1) - fact*Du(i)
                  DO j = 1 , Nrhs
                     B(i+1,j) = B(i+1,j) - fact*B(i,j)
                  ENDDO
               ELSE
                  Info = i
                  RETURN
               ENDIF
               Dl(i) = ZERO
            ELSE
!
!              Interchange rows I and I+1
!
               fact = D(i)/Dl(i)
               D(i) = Dl(i)
               temp = D(i+1)
               D(i+1) = Du(i) - fact*temp
               Dl(i) = Du(i+1)
               Du(i+1) = -fact*Dl(i)
               Du(i) = temp
               DO j = 1 , Nrhs
                  temp = B(i,j)
                  B(i,j) = B(i+1,j)
                  B(i+1,j) = temp - fact*B(i+1,j)
               ENDDO
            ENDIF
         ENDDO
         IF ( N>1 ) THEN
            i = N - 1
            IF ( ABS(D(i))<ABS(Dl(i)) ) THEN
               fact = D(i)/Dl(i)
               D(i) = Dl(i)
               temp = D(i+1)
               D(i+1) = Du(i) - fact*temp
               Du(i) = temp
               DO j = 1 , Nrhs
                  temp = B(i,j)
                  B(i,j) = B(i+1,j)
                  B(i+1,j) = temp - fact*B(i+1,j)
               ENDDO
            ELSEIF ( D(i)/=ZERO ) THEN
               fact = Dl(i)/D(i)
               D(i+1) = D(i+1) - fact*Du(i)
               DO j = 1 , Nrhs
                  B(i+1,j) = B(i+1,j) - fact*B(i,j)
               ENDDO
            ELSE
               Info = i
               RETURN
            ENDIF
         ENDIF
         IF ( D(N)==ZERO ) THEN
            Info = N
            RETURN
         ENDIF
      ENDIF
!
!     Back solve with the matrix U from the factorization.
!
      IF ( Nrhs<=2 ) THEN
         j = 1
         DO
            B(N,j) = B(N,j)/D(N)
            IF ( N>1 ) B(N-1,j) = (B(N-1,j)-Du(N-1)*B(N,j))/D(N-1)
            DO i = N - 2 , 1 , -1
               B(i,j) = (B(i,j)-Du(i)*B(i+1,j)-Dl(i)*B(i+2,j))/D(i)
            ENDDO
            IF ( j<Nrhs ) THEN
               j = j + 1
               CYCLE
            ENDIF
            EXIT
         ENDDO
      ELSE
         DO j = 1 , Nrhs
            B(N,j) = B(N,j)/D(N)
            IF ( N>1 ) B(N-1,j) = (B(N-1,j)-Du(N-1)*B(N,j))/D(N-1)
            DO i = N - 2 , 1 , -1
               B(i,j) = (B(i,j)-Du(i)*B(i+1,j)-Dl(i)*B(i+2,j))/D(i)
            ENDDO
         ENDDO
      ENDIF
!
!
!     End of DGTSV
!
      END SUBROUTINE DGTSV


      subroutine bulgepotential(bulgemass, bulgeedge)

      include 'commonblocks'

      real bulgepot(20,0:nmax), bulgefr(20,0:nmax)

      idiskflagint = 0
      ibulgeflagint = 1
      ihaloflagint = 0
      ibhflagint = 0
c Now get the harmonics of the density in this potential --> adens
      ntheta=lmax*4+2
      eps = 0.0001
      adens(1,0)=bulgedens(eps,0.0)*sqrt(4.*pi)
      do l=2,lmax,2
         adens(l/2+1,0)=0
         enddo
      do ir=1,nr
         adens(1,ir)=0
         enddo
c nrmax will mark the outermost radial bin with non-zero density.
      nrmx=nr
      do l=0,lmax,2
c integrate density * spherical harmonic function over quadrant
         do ir=1,nrmx
            r=ir*dr
            s=0
            dctheta=1.0/ntheta
            s=s+polarbulgedens(r,1.0,l)+polarbulgedens(r,0.0,l)
            do is=1,ntheta-1,2
               ctheta=is*dctheta
               s=s+4*polarbulgedens(r,ctheta,l)
            enddo
            do is=2,ntheta-2,2
               ctheta=is*dctheta
               s=s+2*polarbulgedens(r,ctheta,l)
            enddo
            s=s*dctheta/3.
            s=s*4*pi
            adens(l/2+1,ir)=s
            enddo
 77      enddo
c     now get the potential harmonics of this new density. Simpson's
c     rule integration. (BT 2-208)
      do l=0,lmax,2
         s1(0)=0
         do ir=2,nr,2
            r=ir*dr
            s1(ir)=s1(ir-2)+(dr/3.)*
     +           (adens(l/2+1,ir-2)*(r-2*dr)**(l+2)+
     +           4*adens(l/2+1,ir-1)*(r-dr)**(l+2)+
     +           adens(l/2+1,ir)*r**(l+2))
            enddo
         s2(nr)=0
         do ir=nr-2,2,-2
            r=ir*dr
            s2(ir)=s2(ir+2)+(dr/3.)*
     +           (adens(l/2+1,ir+2)*(r+2*dr)**(1-l)+
     +           4*adens(l/2+1,ir+1)*(r+dr)**(1-l)+
     +           adens(l/2+1,ir)*r**(1-l))
            enddo
         do ir=2,nr,2
            bulgepot(l/2+1,ir)=-4*pi/(2.*l+1.)*
     +              (s1(ir)/(ir*dr)**(l+1)+s2(ir)*(ir*dr)**l)
            enddo
c
c  Calculate the radial gradients
c
         do ir=2,nr,2
            bulgefr(l/2+1,ir)=-4*pi/(2.*l+1.)*
     +              (-(l+1)*s1(ir)/(ir*dr)**(l+2)+
     +           l*s2(ir)*(ir*dr)**(l-1))
            enddo
         enddo
c     now interpolate the gaps first quadratically interpolate the
c     monopole back to the origin.  the remaining multipoles are zero
c     there.
      bulgepot(1,0)=(4*bulgepot(1,2)-bulgepot(1,4))/3.
      fr(1,0)=0.0
      do l=2,lmax,2
         bulgepot(l/2+1,0)=0
         bulgefr(l/2+1,0)=0
         enddo
      do ir=1,nr-1,2
         do l=0,lmax,2
            bulgepot(l/2+1,ir)=(bulgepot(l/2+1,ir-1)+
     +           bulgepot(l/2+1,ir+1))/2.
            bulgefr(l/2+1,ir)=(bulgefr(l/2+1,ir-1)+
     +           bulgefr(l/2+1,ir+1))/2.
            enddo
         enddo
      a00=bulgepot(1,0)
      do ir=0,nr
         bulgepot(1,ir)=bulgepot(1,ir)-a00
         enddo
c write bulge final potential.
c
c Reset the potentials so that phi is 0 at infinity
c
      redge = nr*dr
      do l=0,lmax,2
          c0 = bulgepot(l/2+1,nr) + bulgefr(l/2+1,nr)*redge/(l+1)
          do i=0,nr
              bulgepot(l/2+1,i) = bulgepot(l/2+1,i) - c0
          enddo
      enddo

      open(11,file='b.dat',status='unknown')
      write(11,'('' # chalo,v0,a,nnn,v0bulge,abulge,dr,nr,lmax='')')
      write(11,'('' #'',7g15.5,i6,i4)') chalo,v0,a,nnn,v0bulge,abulge,
     +     dr,nr,lmax
      write(11,'('' # psi0, haloconst, bulgeconst:'')')
      write(11,'('' #'',3g15.5)') psi0,haloconst,bulgeconst
      write(11,'('' # Mdisk, rdisk, zdisk, outdisk, drtrunc'')')
      write(11,'('' #'',5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      write(11,'('' # psic,psid,bhmass'')')
      write(11,'('' #'',3g15.5)') psic,psid,bhmass
      write(11,'('' #'',4i5)') idiskflagint, ibulgeflagint,
     +     ihaloflagint, ibhflagint
      write(11,'('' #  OUTPUT FROM DBH8. TOTAL POTENTIAL.'')')

      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(adens(l/2+1,ir),l=0,lmax,2)
         enddo
      write(11,*)
      write(11,*)
      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(bulgepot(l/2+1,ir),l=0,lmax,2)
         enddo
      write(11,*)
      write(11,*)
      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(bulgefr(l/2+1,ir),l=0,lmax,2)
         enddo
      close(11)

      bulgemass = bulgefr(1,nr)/sqrt(4*pi)*(nr*dr)**2
      do ir=0, nr
          if( adens(1,ir) .eq. 0.0 ) then
              bulgeedge = ir*dr
              goto 999
          endif
      enddo
      bulgeedge = nr*dr
999   write(*,*) 'Bulge mass =', bulgemass
      write(*,*) 'Bulge edge radius =', bulgeedge
      write(*,*) 'Bulge harmonics written to file ''b.dat''.'
      return
      end


	SUBROUTINE DP_PGRB  ( grid, igx, igy, nbits, idata, lendat,
     +			      qmin, scale, iret )
C************************************************************************
C* DP_PGRB								*
C*									*
C* This subroutine packs a grid into the GEMPAK GRIB format using the	*
C* number of bits specified.  The packing and unpacking equations are:	*
C*									*
C*	IDATA  =  NINT ( ( GRID - QMIN ) / SCALE )			*
C*	GRID   =  QMIN  +  IDATA * SCALE				*
C*									*
C* DP_PGRB  ( GRID, IGX, IGY, NBITS, IDATA, LENDAT, QMIN, SCALE,	*
C*            IRET )							*
C*									*
C* Input parameters:							*
C*	GRID (IGX,IGY)	REAL		Grid data			*
C*	IGX		INTEGER		Number of points in x dir	*
C*	IGY		INTEGER		Number of points in y dir	*
C*	NBITS		INTEGER		Number of bits			*
C*									*
C* Output parameters:							*
C*	IDATA (LENDAT)	INTEGER		Packed data			*
C*	LENDAT		INTEGER		Length of packed data array	*
C*	QMIN		REAL		Minimum value of grid		*
C*	SCALE		REAL		Scaling factor			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-10 = NBITS invalid		*
C*					-11 = invalid data range	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C* K. Brill/GSC		 2/90	Fix to find negative max on grid	*
C* K. Brill/NMC		03/92	Fix for constant grid			*
C* H. Zeng/SAIC		09/07	Fixed constant grib with missing data	*
C* K. Brill/HPC         03/09   Fix infinite loop for NINT cycling	*
C* K. Tyle/UAlbany	10/10	Fixed for case with all missing data	*
C* S. Decker/Rutgers     6/19   Fix infinite loop for very small qdif   *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (*)
	INTEGER		idata (*)
	LOGICAL		hvmis, allmis
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	kxky = igx * igy
C
C*	Check for valid input.
C
	IF  ( ( nbits .le. 1 ) .or. ( nbits .gt. 31 ) )  THEN
	    iret = -10
	    RETURN
	END IF
C
C*	Compute the number of output words and initialize the output
C*	buffer and scaling parameter.
C
	lendat = FLOAT ( nbits * kxky ) / 32.0
	IF  ( lendat * 32 .ne. nbits * kxky ) lendat = lendat + 1
	DO  ii = 1, lendat
	    idata(ii) = 0
	END DO
	scale = 1.0
C
C*	Read through the grid finding the minimum and maximum values.
C
	hvmis = .false.
	allmis = .true.
	qmin = 1.0E+31
	qmax = -1.0E+31
	DO  ii = 1, kxky
	    IF  ( .not. ERMISS ( grid(ii) ) )  THEN
		IF  ( grid(ii) .lt. qmin )  qmin = grid(ii)
		IF  ( grid(ii) .gt. qmax )  qmax = grid(ii)
		allmis = .false.
	    ELSE
		hvmis = .true.
	    END IF
	END DO
C
C*	If all points in the grid are set to missing,
C*	set the min and max values to missing.
C
	IF ( allmis )  THEN
	    qmin = RMISSD
	    qmax = RMISSD
	ENDIF
C
C*	Find the data range and check that it is valid.
C
	qdif = qmax - qmin
	IF  ( qdif .lt. 0.0 )  THEN
	    iret = -11
	    RETURN
	ELSE IF ( qdif .eq. 0.0 .and. .not. hvmis ) THEN
	    RETURN
	END IF
C
C*	Find the scaling factor.  The scaling factor is set to a
C*	power of 2.
C
	nnnn = 0
	idat = NINT ( qdif )
	IF ( idat .lt. 0 ) THEN
C
C*	    If qdif is too large, NINT will cycle the integer to a
C*          negative value, which will cause an infinite loop.
C
	    iret = -11
	    RETURN
	END IF
	imax = 2 ** nbits - 1
	IF  ( ABS(qdif) .gt. TINY(qdif) * imax ) THEN
C
	  IF ( idat .ge. imax )  THEN
	    DO WHILE  ( idat .ge. imax )
		nnnn = nnnn - 1
		idat = qdif * 2.0 ** nnnn
	    END DO
	  ELSE
	    DO WHILE  ( NINT ( qdif * 2.0 ** (nnnn+1) ) .lt. imax )
		nnnn = nnnn + 1
	    END DO
	  END IF
C
	END IF
C
	scale = 2.0 ** nnnn
C
C*	Add data points to output buffer.
C
	iword = 1
	ibit  = 1
	DO  ii = 1, kxky
C
C*	    Turn grid value into an integer.
C
	    IF  ( ERMISS ( grid(ii) ) )  THEN
		idat = imax
	      ELSE
		gggg = grid(ii) - qmin
		IF  ( gggg .lt. 0.0 ) gggg = 0.0
		idat = NINT ( gggg * scale )
	    END IF
C
C*	    Shift bits to correct location in word.
C
	    jshft = 33 - nbits - ibit
	    idat2 = ISHFT ( idat, jshft )
	    idata (iword) = IOR ( idata (iword), idat2 )
C
C*	    Check to see if packed integer overflows into next word.
C
	    IF  ( jshft .lt. 0 )  THEN
		jshft = 32 + jshft
		idata (iword+1) = ISHFT ( idat, jshft )
	    END IF
C
C*	    Set location for next word.
C
	    ibit = ibit + nbits
	    IF  ( ibit .gt. 32 )  THEN
		ibit  = ibit - 32
		iword = iword + 1
	    END IF
	END DO
C
C*	The scale factor to be saved is really the reciprocal of the
C*	scale which was computed.
C
	scale = 1.0 / scale
C*
	RETURN
	END


!##############################################################################
! PROGRAM RBC_cost
!
! ## Calculates the cost of business cycle fluctuations
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog09_06m.f90"

program RBC_cost

    ! modules
    use globals
    use toolbox

    implicit none

    ! start timer
    call tic()

    ! calculate the shock process
    call discretize_AR(rho, 0d0, sigma_eps, eta, pi)

    ! initialize grid and policy function
    call grid_Cons_Equi(k, k_l, k_u)
    do is = 1, ns
        l(:, is) = 0.3d0
        c(:, is) = exp(eta(is))*k(:)**alpha*l(:, is)**(1d0-alpha)
        c_new(:, is) = c(:, is)
    enddo

    ! iterate until policy function converges
    do iter = 1, itermax

        ! interpolate coefficients
        call interpolate()

        ! calculate decisions for every gridpoint and shock level
        do ik = 0, NK
            do is = 1, NS

                ! sets starting value and communicate resource level
                x_in = l(ik, is)
                k_com = k(ik)
                is_com = is

                ! find the optimal labor supply level
                call fzero(x_in, foc, check)
                if(check)write(*,*)'ERROR IN ROOTFINDING PROCESS'

                ! get optimal consumption function
                l(ik, is) = x_in
                c_new(ik, is) = nu/(1d0-nu)*(1d0-x_in)*exp(eta(is))*(1d0-alpha)*(k(ik)/x_in)**alpha

            enddo
        enddo

        ! get convergence level
        con_lev = maxval(abs(c_new(:, :) - c(:, :))/max(abs(c(:, :)), 1d-10))
        if(mod(iter,50) == 0)write(*,'(i5,2x,f20.7)')iter, con_lev

        ! check for convergence
        if(con_lev < sig)then
            call output()
        endif

        c = c_new
    enddo

    write(*,*)'No Convergence'

contains

    ! For interpolating the RHS of the first order condition
    subroutine interpolate()

        use toolbox

        implicit none
        integer :: is, ik, is_p
        real*8 :: marg_util

        do is = 1, NS
            do ik = 0, NK

                ! calculate the RHS of the first order condition
                RHS(ik, is) = 0d0
                do is_p = 1, NS
                    marg_util = nu*(c_new(ik, is_p)**nu*(1d0-l(ik, is_p))**(1d0-nu))**egam/c_new(ik, is_p)
                    RHS(ik, is) = RHS(ik, is) + pi(is, is_p)* &
                        (1d0+exp(eta(is_p))*alpha*(k(ik)/l(ik, is_p))**(alpha-1d0)-delta)*marg_util
                enddo
                RHS(ik, is) = (beta*RHS(ik, is))**(-gamma)
            enddo

            ! interpolate
            call spline_interp(RHS(:, is), coeff_r(:, is))
        enddo

    end subroutine

    ! For creating output plots
    subroutine output()

        use toolbox

        implicit none
        real*8 :: Omega, k_star, c_star, l_star, u_star
        real*8 :: CV_leis, cor_leis
        real*8 :: u_mu, u_hat, bar_nu
        real*8 :: bc_lev, bc_c, bc_leis, bc_cor, bc_tot
        integer, parameter :: n_err = 10000
        real*8 :: err, c_err, l_err, err_temp

        ! end timer
        call toc()

        ! interpolate policy functions
        do is = 1, NS
            call spline_interp(c_new(:, is), coeff_c(:, is))
            call spline_interp(l(:, is), coeff_l(:, is))
        enddo

        ! determine the stochastic steady state
        is_t = floor(dble(NS)/2d0)+1
        call simulate_economy()
        k0 = k_t(TT)

        ! simulate a series of shocks
        call simulate_AR(pi, is_t)

        ! simulate the economy forward
        call simulate_economy()

        ! calculate business cycle statistics
        call bc_statistics()

        ! write output
        write(*,'(//a/)')'BUSINESS CYCLE MOMENTS'
        write(*,'(a)')'                               c       i       k       l       r       w'
        write(*,'(a,6f8.2)')'Mean:                   ',(/E_c, E_i, E_k/)/E_y*100d0, (/E_l, E_r/)*100d0, E_w

        write(*,'(a,6f8.2)')'CV (in % of CV of GDP): ',(/CV_c, CV_i, CV_k, CV_l, CV_r, CV_w/)/CV_y
        write(*,'(a,6f8.2)')'Corr. with GDP:         ',Cor_c, Cor_i, Cor_k, Cor_l, Cor_r, Cor_w

        !########################################################
        ! GET THE COST OF THE BUSINESS CYCLE
        !########################################################

        ! get CV and correlation
        CV_leis  = CofVar(1d0-l_t)
        Cor_leis = correlation(c_t, 1d0-l_t)

        ! determine steady state values under certainty
        Omega  = exp(0.5d0*sigma_eps/(1d0-rho**2))
        k_star = ((Omega*alpha)/(1d0/beta-1d0+delta))**(1d0/(1d0-alpha))
        l_star = nu*Omega*(1d0-alpha)*k_star**alpha/ &
            ((1d0-nu*alpha)*Omega*k_star**alpha - (1d0-nu)*delta*k_star)
        c_star = (Omega*k_star**alpha-delta*k_star)*l_star

        ! get different utility levels
        u_star = (c_star**nu*(1d0-l_star)**(1d0-nu))**egam/egam
        u_mu   = (E_c**nu*(1d0-E_l)**(1d0-nu))**egam/egam
        u_hat  = u_mu/u_star
        E_V    = sum((c_t**nu*(1d0-l_t)**(1d0-nu))**egam/egam)/dble(TT+1)

        ! get different components of business cycle costs
        bar_nu  = (1d0-nu)*nu*gamma
        bc_lev  = (u_hat-1d0)/(nu*egam)
        bc_c    = -u_hat/(2d0*nu*gamma)*(nu**2 + bar_nu)*CV_c**2
        bc_leis = -u_hat/(2d0*nu*gamma)*((1d0-nu)**2 + bar_nu)*CV_leis**2
        bc_cor  = -u_hat/(nu*gamma)*(nu*(1d0-nu) - bar_nu)*Cor_leis*CV_c*CV_leis
        bc_tot  = bc_lev + bc_c + bc_leis + bc_cor

        write(*,'(//a/)')'COST OF THE BUSINESS CYCLE'
        write(*,'(a)')'                     LEVEL       CV(c)       CV(l)    RHO(c,l)       TOTAL'
        write(*,'(a,12x,3f12.5)')'Values:       ',CV_c, CV_leis, Cor_leis
        write(*,'(a,5f12.5)')'Aprox. cost:  ',(/bc_lev, bc_c, bc_leis, bc_cor, bc_tot/)*100d0
        write(*,'(a,48x,f12.5//)')'Model sim.:   ',((E_V/u_star)**(1d0/(nu*egam))-1d0)*100d0

        ! calculate euler equation error
        err = 0d0
        do ik = 0, n_err
            k_com = k_l + (k_u-k_l)*dble(ik)/dble(n_err)
            do is = 1, NS
                is_com = is
                c_err = spline_eval(k_com, coeff_c(:, is), k_l, k_u)
                l_err = spline_eval(k_com, coeff_l(:, is), k_l, k_u)
                err_temp = abs(foc2(l_err)/c_err)
                if(err_temp > err)err = err_temp
            enddo
        enddo
        write(*,'(a, es15.7)')'Euler equation error:',err

        ! quit program
        stop

    end subroutine

    ! simulates the economy for a given series of shocks
    subroutine simulate_economy()

        implicit none

        ! calculate the time path of all economic variables
        eta_t(0) = eta(is_t(0))
        k_t(0) = k0
        c_t(0) = spline_eval(k_t(0), coeff_c(:, is_t(0)), k_l, k_u)
        l_t(0) = spline_eval(k_t(0), coeff_l(:, is_t(0)), k_l, k_u)
        y_t(0) = exp(eta_t(0))*k_t(0)**alpha*l_t(0)**(1d0-alpha)
        i_t(0) = y_t(0)-c_t(0)
        r_t(0) = exp(eta_t(0))*alpha*(l_t(0)/k_t(0))**(1d0-alpha) - delta
        w_t(0) = exp(eta_t(0))*(1d0-alpha)*(k_t(0)/l_t(0))**(alpha)
        do it = 1, TT
            eta_t(it) = eta(is_t(it))
            k_t(it) = (1d0-delta)*k_t(it-1) + i_t(it-1)
            c_t(it) = spline_eval(k_t(it), coeff_c(:, is_t(it)), k_l, k_u)
            l_t(it) = spline_eval(k_t(it), coeff_l(:, is_t(it)), k_l, k_u)
            y_t(it) = exp(eta_t(it))*k_t(it)**alpha*l_t(it)**(1d0-alpha)
            i_t(it) = y_t(it)-c_t(it)
            r_t(it) = exp(eta_t(it))*alpha*(l_t(it)/k_t(it))**(1d0-alpha) - delta
            w_t(it) = exp(eta_t(it))*(1d0-alpha)*(k_t(it)/l_t(it))**alpha
        enddo

    end subroutine

    ! calculates business cycle statistics
    subroutine bc_statistics()

        implicit none

        ! calculate expectations
        E_c = sum(c_t)/dble(TT+1)
        E_i = sum(i_t)/dble(TT+1)
        E_k = sum(k_t)/dble(TT+1)
        E_l = sum(l_t)/dble(TT+1)
        E_r = sum(r_t)/dble(TT+1)
        E_w = sum(w_t)/dble(TT+1)
        E_y = sum(y_t)/dble(TT+1)

        ! normalization on annual level
        E_k = E_k/4d0
        E_r = (1d0+E_r)**4-1d0

        ! calculate coefficient of variation
        CV_c = CofVar(c_t)
        CV_i = CofVar(i_t)
        CV_k = CofVar(k_t)
        CV_l = CofVar(l_t)
        CV_r = CofVar(r_t)
        CV_w = CofVar(w_t)
        CV_y = CofVar(y_t)

        ! calculate correlation coefficients of logs
        Cor_c = correlation(c_t, y_t)
        Cor_i = correlation(i_t, y_t)
        Cor_k = correlation(k_t, y_t)
        Cor_l = correlation(l_t, y_t)
        Cor_r = correlation(r_t, y_t)
        Cor_w = correlation(w_t, y_t)

    end subroutine

    ! Calculates coefficient of variation
    function CofVar(x)

        implicit none
        real*8, intent(in) :: x(0:TT)
        real*8 :: CofVar, mean
        integer :: it

        mean = sum(x)/dble(TT+1)
        CofVar = 0d0
        do it = 0, TT
            CofVar = CofVar + (x(it)-mean)**2
        enddo
        CofVar = sqrt(CofVar/dble(TT))/max(mean, 1d-10)

    end function

    ! Calculates correlation coefficient
    function correlation(x, y)

        implicit none
        real*8, intent(in) :: x(0:TT), y(0:TT)
        real*8 :: correlation, variance1, variance2, mean1, mean2
        integer :: it

        mean1 = sum(x)/dble(TT+1)
        mean2 = sum(y)/dble(TT+1)
        variance1   = 0d0
        variance2   = 0d0
        correlation = 0d0
        do it = 0, TT
            variance1   = variance1   + (x(it)-mean1)**2
            variance2   = variance2   + (y(it)-mean2)**2
            correlation = correlation + (x(it)-mean1)*(y(it)-mean2)
        enddo
        variance1   = variance1/dble(TT)
        variance2   = variance2/dble(TT)
        correlation = correlation/dble(TT)/max(sqrt(variance1*variance2), 1d-10)

    end function

end program


Real Function pnlka(srt)
  Save
  ala = 1.116
  aka = 0.498
  ana = 0.939
  t1 = ala + aka
  If (srt<=t1) Then
     pnlka = 0
  Else
     If (srt<1.7) sbbk = (0.9/0.091)*(srt-t1)
     If (srt>=1.7) sbbk = 0.09/(srt-1.6)
     pnlka = 0.25*sbbk
     pnlka = pnlka/10.
  End If
  Return
End Function pnlka


      PROGRAM ROSEN
CD0
CD0   IDENTIFICATION :
CD0
CD0         PROGRAMMER -  J.D. FRICK, MDAC/HOUSTON
CD0         VERSION    -  SEPTEMBER 1986
CD1
CD1   PURPOSE :
CD1
CD1         THIS IS A SIMPLE DRIVER PROGRAM FOR VMACO. CONTAINED BELOW
CD1         IS THE ROSENBROCK CURVED VALLEY TEST CASE. IT HAS 2 CONTROL
CD1         VARIABLES AND NO CONSTRAINTS.
CD2
CD2   CALLING ARGUMENT INPUT :
CD2
CD2      NAME    DEFINITION
CD2
CD2      NONE
CD3
CD3   CALLING ARGUMENT OUTPUT :
CD3
CD3      NAME    DEFINITION
CD3
CD3      ACC     CONTROLS THE FINAL ACCURACY FOR CONVERGENCE. CON-
CD3              VERGENCE OCCURS WHEN THE VALUE FOR THE CHANGE IN
CD3              OBJECTIVE FUNCTION PLUS SUITABLY WEIGHTED MULTI-
CD3              PLIERS  OF THE CONSTRAINT FUNCTION DIFFERS FROM
CD3              ITS PREVIOUS VALUE BY AT MOST ACC.
CD3      C       VECTOR OF CONSTRAINT VARIABLES.
CD3      CNORML  MATRIX OF CONSTRAINT NORMALS
CD3      F       VALUE OF THE OBJECTIVE FUNCTION (OPTIMIZED VARIABLE)
CD3      G       GRADIENT OF THE OBJECTIVE FUNCTION
CD3      IPRINT  FLAG TO INDICATE AMOUNT OF PRINTOUT
CD3              = 0 NO PRINTOUT
CD3              = 1 VALUES OF X, C, AND F ARE PRINTED
CD3              = 2 DEBUG PRINTOUT
CD3      ISTAT   INDEX TO INDICATE THE STATUS OF THE OPTIMIZATION
CD3              ALGORITHM.
CD3              =-1 INITIAL PASS THROUGH VMACO
CD3              = 0 CONTINUE ALGORITHM CALCULATIONS
CD3              = 1 CONVERGE WITHIN REQUIRED ACURRACY
CD3              > 1 ERROR ENCOUNTERED
CD3      M       TOTAL NUMBER OF CONSTRAINTS (I.E. CONSTRAINT EQUATIONS)
CD3      MAXFUN  MAXIMUM NUMBER OF TIMES VMACO CAN BE CALLED
CD3      MEQ     TOTAL NUMBER OF EQUALITY CONSTRAINTS
CD3      N       NUMBER OF CONTROL VARIABLES
CD3      NSIZE   CORRESPONDS TO THE MAXIMUM DIMENSION OF THE INNERMOST
CD3              ARRAY SIZE FROM THE CNORML MATRIX (I.E. MAX CONTROL
CD3              VARIABLE SIZE). THIS ALLOWS CORRECT COMMUNICATION
CD3              BETWEEN THE CNORML AND CN MATRIX.
CD3      X       VECTOR OF CONTROL VARIABLES
CD4
CD4   COMMON VARIABLE INPUT
CD4
CD4      NAME    DEFINITION
CD4
CD4      NONE
CD5
CD5   COMMON VARIABLE OUTPUT
CD5
CD5      NAME    DEFINITION
CD5
CD5      NONE
CD6
CD6   INTERNAL VARIABLES
CD6
CD6      NAME    DEFINITION
CD6
CD6      MSIZE   SIZE OF ARRAYS PERTAINING TO THE CONSTRAINTS
CD7
CD7   LIMITATIONS/ASSUMPTIONS
CD7
CD7      NONE
C
C***********************************************************************
C
      PARAMETER ( MSIZE  =    4 )
      PARAMETER ( NSIZE  =    4 )
C
      DIMENSION C      (NSIZE )
      DIMENSION CNORML (NSIZE ,MSIZE )
      DIMENSION G      (NSIZE )
      DIMENSION X      (NSIZE )
C
C************************************************************************
C
      N = 2
      M = 0
      MEQ = 0
C
      MAXFUN = 100
      ACC = 1.E-7
      IPRINT = 1
      ISTAT = -1
C
C.....AN INITIAL GUESS IS MADE
C
      X(1) = -1.
      X(2) = 1.
C
C.....THE OBJECTIVE FUNCTION AND ITS GRADIENT ARE CALCULATED
C
   20 CONTINUE
C
      F = 100*(X(2)-X(1)**2)**2 + (1-X(1))**2
C
      G(1) = -400*X(1)*(X(2)-X(1)**2) - 2*(1-X(1))
      G(2) = 200*(X(2)-X(1)**2)
C
      CALL VMACO (N,M,MEQ,X,F,G,C,CNORML,NSIZE,MAXFUN,ACC,
     1            ISTAT,IPRINT)
C
      IF (ISTAT .EQ. 0) THEN
        GO TO 20
      ENDIF
C
      STOP
      END


FUNCTION factln(n)
!
IMPLICIT NONE
!
! Function arguments
!
INTEGER :: n
REAL :: factln
!
! Local variables
!
REAL,DIMENSION(100) :: a
REAL :: gammln
!
!     + + + purpose + + +
!     computes the ln(n!) for n > 0
!
!     based on:
!     'numerical recipes - the art of scientific computing',
!     w.h. press, b.p. flannery, s.a. teukolsky, w.t. vetterling
!     cambridge university press, 1986
!     pg 159
!
!     + + + keywords + + +
!     factorial
!
!     + + + argument declarations + + +
!
!
!     + + + argument definitions + + +
!     n      - real value for values >= 0
!
!     + + + local variables + + +
!
!
DATA a/100* - 1/
!
!     + + + end specifications + + +
!
IF (n.LT.0) WRITE (*,*) 'in function factln(n): negative factorial!!'
IF (n.LE.99) THEN
  IF (a(n+1).LT.0.0) a(n+1) = gammln(n+1.0)
  factln = a(n+1)
ELSE
  factln = gammln(n+1.0)
END IF
!
END FUNCTION factln

Project Documents/Source Code Original/Factln.f90