c
c  This file contains the Helmholtz FMM wrappers
c
c  The Helmholtz FMM evaluates the following potential
c  and its gradient
c
c     u_{l}(x) = \sum_{j=1}^{N} c_{l,j}e^{ik|x-x_{j}|}/|x-x_{j}| -
c         v_{l,j}.\nabla (e^{ik|x-x_{j}|/|x-x_{j}|)
c
c  Here x_{j} are the source locations, c_{l,j} are the charge strengths,
c  v_{l,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  This file contains the wrappers to the vectorized routines
c
c  The subroutine names take the following form:
c    hfmm3d_<eval-pts>_<int-ker>_<out>_vec
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
c  The wrappers are:
c
c  -hfmm3d_s_c_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_s_c_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_s_d_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_s_d_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_s_cd_p_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_s_cd_g_vec
c    - Evaluation points: Sources
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_t_c_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_t_c_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_t_d_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_t_d_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_t_cd_p_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_t_cd_g_vec
c    - Evaluation points: Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_st_c_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_st_c_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_st_d_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_st_d_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c  -hfmm3d_st_cd_p_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential
c-------------------------------------
c  -hfmm3d_st_cd_g_vec
c    - Evaluation points: Sources and Targets
c    - Interaction kernel: Charges and Dipoles
c    - Outputs requested: Potential and Gradient
c-------------------------------------
c
c

      subroutine hfmm3d_s_c_p_vec(nd,eps,zk,nsource,source,
     1    charge,pot)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource)
      double complex pottarg(nd,1)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_s_c_g_vec(nd,eps,zk,nsource,source,
     1    charge,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,1),gradtarg(nd,3,1)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

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

      return
      end
c
c
c
c
c
c

      subroutine hfmm3d_s_d_p_vec(nd,eps,zk,nsource,source,
     1    dipvec,pot)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,nsource)
      double complex pottarg(nd,1)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_s_d_g_vec(nd,eps,zk,nsource,source,
     1    dipvec,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,1),gradtarg(nd,3,1)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_s_cd_p_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,pot)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource)
      double complex pottarg(nd,1)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      ntarg = 0

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

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

      subroutine hfmm3d_s_cd_g_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,pot,grad)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(out) pot,grad
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,j}$
c
c
c  Output arguments:
c
c    -    pot: double complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,1),gradtarg(nd,3,1)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      ntarg = 0

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

      return
      end
c
c
c
c
c
c

      subroutine hfmm3d_t_c_p_vec(nd,eps,zk,nsource,source,
     1    charge,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,1)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c
c

      subroutine hfmm3d_t_c_g_vec(nd,eps,zk,nsource,source,
     1    charge,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,1),grad(nd,3,1)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_t_d_p_vec(nd,eps,zk,nsource,source,
     1    dipvec,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,1)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_t_d_g_vec(nd,eps,zk,nsource,source,
     1    dipvec,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,1),grad(nd,3,1)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_t_cd_p_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,1)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c
c

      subroutine hfmm3d_t_cd_g_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,1),grad(nd,3,1)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_st_c_p_vec(nd,eps,zk,nsource,source,
     1    charge,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_st_c_g_vec(nd,eps,zk,nsource,source,
     1    charge,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c
c

      subroutine hfmm3d_st_d_p_vec(nd,eps,zk,nsource,source,
     1    dipvec,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,nsource)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_st_d_g_vec(nd,eps,zk,nsource,source,
     1    dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = -\sum_{j=1}^{N} v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_st_cd_p_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,pot,ntarg,targ,pottarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot
cf2py  intent(out) pottarg
c-------------------------------------
c
c  This subroutine evaluates the potential
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource)
      double complex pottarg(nd,ntarg)

      double complex grad(nd,3),gradtarg(nd,3)
      double complex hess(nd,6),hesstarg(nd,6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

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

      return
      end
c
c
c
c
c

      subroutine hfmm3d_st_cd_g_vec(nd,eps,zk,nsource,source,
     1    charge,dipvec,pot,grad,ntarg,targ,pottarg,
     2    gradtarg)
cf2py  intent(in) nd,eps
cf2py  intent(in) zk
cf2py  intent(in) nsource,source,dipvec,charge
cf2py  intent(in) ntarg,targ
cf2py  intent(out) pot,grad
cf2py  intent(out) pottarg,gradtarg
c-------------------------------------
c
c  This subroutine evaluates the potential and its gradient
c      u_{\ell}(x) = \sum_{j=1}^{N} c_{\ell,j}
c        \frac{e^{ik\|x- x_{j}\|}}{\|x-x_{j}\|} -
c            v_{\ell,j} \cdot \nabla \left(
c        \frac{e^{ik\|x-x_{j}\|}}{\|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    -    nd: integer
c          number of densities
c    -    eps: double precision
c          precision requested
c    -    zk: double complex
c          Helmholtz parameter (k)
c    -    nsource: integer
c          Number of sources
c    -    source: double precision(3,nsource)
c          Source locations, $x_{j}$
c    -    charge: double complex(nd,nsource)
c          Charge strengths, $c_{\ell,j}$
c    -    dipvec: double complex(nd,3,nsource)
c          Dipole strengths, $v_{\ell,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 complex(nd,nsource)
c          Potential at source locations, $u_{\ell}(x_{j})$
c    -    grad: double complex(nd,3,nsource)
c          Gradient at source locations, $\nabla u_{\ell}(x_{j})$
cc    -    pottarg: double complex(nd,ntarg)
c          Potential at target locations, $u_{\ell}(t_{i})$
c    -    gradtarg: double complex(nd,3,ntarg)
c          Gradient at target locations, $\nabla u_{\ell}(t_{i})$
c
c
c--------------------------------
c
      implicit none
      double precision eps
      double complex zk

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

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

      double complex pot(nd,nsource),grad(nd,3,nsource)
      double complex pottarg(nd,ntarg),gradtarg(nd,3,ntarg)

      double complex hess(6),hesstarg(6)

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

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

      return
      end
c
c
c
c
c


module idecomp

use utils

contains

subroutine idecomp_construct(eps,a,krank,ipivs,r)
implicit double precision (a-h,o-z)

double precision               :: eps,a(:,:)
integer, allocatable           :: ipivs(:)
double precision, allocatable  :: r(:,:)

!
!
!

! double precision, allocatable :: c(:,:),q(:,:),rnorms(:),work(:),rinv(:,:),r0(:,:)
! integer, allocatable          :: idxs(:)

double precision, allocatable :: q(:,:),rnorms(:),c(:,:),rinv(:,:),work(:),r2(:,:),r0(:,:)

n   = size(a,1)
m   = size(a,2)

allocate(rnorms(n+m+1000),q(n,m),ipivs(m))

q = a
call gspiv(q,n,m,eps,rnorms,ipivs,krank)
! call prini("krank = ",krank)
! call prin2("rnorms = ",rnorms(1:krank))
! call prini("ipivs = ",ipivs)

call insorti(krank,ipivs(1:krank))
! call prini("ipivs = ",ipivs(1:krank))

allocate(r2(krank,m),c(n,m),rinv(krank,krank),work(krank*krank*8 + 1000))

c = a(:,ipivs)

r2 = matmul(transpose(q(:,1:krank)),c)
rinv = r2(1:krank,1:krank)
call orthom(rinv,krank,work,cond)

allocate(r(krank,m),r0(krank,m))
r0 = matmul(rinv,r2)

! print *,norm2(c - matmul(c(:,1:krank),r0))
! print *,norm2(a - matmul(c(:,1:krank),r(:,ipivs)))

do j=1,m
r(:,ipivs(j)) = r0(:,j)
end do

! r = 0
! do j=1,krank
! r(j,j) = 1
! end do
! r(:,krank+1:m) = matmul(rinv,c(:,krank+1:m))

! ! reorder r
! ! r = r(:,ipivs)
! do j=1,m
! r(:,j) = r0(:,ipivs(j))
! end do

end subroutine

end module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine distattach_3d(xig,etg,zeg,pneigh,pnode,a,p,ratio,
     &          nterms)
!
!     calculates the distance between the node with coordinates
!     in "pnode" and the node with local coordinates xig and etg
!     in a face described by "nterms" nodes with coordinates
!     in pneigh
!
      implicit none
!
      integer nterms,i,j,n
!
      real*8 ratio(20),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3),
     &  dummy,ze,zeg,omg,omh,omr,opg,oph,opr,dx(3),al,
     &  tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr,
     &  omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr
!
!
!
      n=3
!
      if(nterms.eq.4) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         ze=(zeg+1.d0)/2.d0
         dx(1)=xi
         dx(2)=et
         dx(3)=ze
         call insertsortd(dx,n)
c         call dsort(dx,iy,n,kflag)
         if(dx(3).gt.1.d-30) then
            al=dx(3)/(xi+et+ze)
            xi=al*xi
            et=al*et
            ze=al*ze
         endif
!
!        shape functions
!
         ratio(1)=1.d0-xi-et-ze
         ratio(2)=xi
         ratio(3)=et
         ratio(4)=ze
      elseif(nterms.eq.6) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         if(xi+et.gt.1.d0) then
            dummy=xi
            xi=1.d0-et
            et=1.d0-dummy
         endif
!
         ze=zeg

         a=1.d0-xi-et
!
!     shape functions
!
         ratio(1)=0.5d0*a *(1.d0-ze)
         ratio(2)=0.5d0*xi*(1.d0-ze)
         ratio(3)=0.5d0*et*(1.d0-ze)
         ratio(4)=0.5d0*a *(1.d0+ze)
         ratio(5)=0.5d0*xi*(1.d0+ze)
         ratio(6)=0.5d0*et*(1.d0+ze)
      elseif(nterms.eq.8) then
         xi=xig
         et=etg
         ze=zeg
!
         omg=1.d0-xi
         omh=1.d0-et
         omr=1.d0-ze
         opg=1.d0+xi
         oph=1.d0+et
         opr=1.d0+ze
!
!        shape functions
!
         ratio(1)=omg*omh*omr/8.d0
         ratio(2)=opg*omh*omr/8.d0
         ratio(3)=opg*oph*omr/8.d0
         ratio(4)=omg*oph*omr/8.d0
         ratio(5)=omg*omh*opr/8.d0
         ratio(6)=opg*omh*opr/8.d0
         ratio(7)=opg*oph*opr/8.d0
         ratio(8)=omg*oph*opr/8.d0
      elseif(nterms.eq.10) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         ze=(zeg+1.d0)/2.d0
         dx(1)=xi
         dx(2)=et
         dx(3)=ze
         call insertsortd(dx,n)
c         call dsort(dx,iy,n,kflag)
         if(dx(3).gt.1.d-30) then
            al=dx(3)/(xi+et+ze)
            xi=al*xi
            et=al*et
            ze=al*ze
         endif
c         if(xi+et+ze.gt.1.d0) then
c            dummy=2.d0*(1.d0-xi-et-ze)/3.d0
c            xi=dummy+xi
c            et=dummy+et
c            ze=dummy+ze
c         endif
!
!        shape functions
!
         a=1.d0-xi-et-ze
         ratio( 1)=(2.d0*a-1.d0)*a
         ratio( 2)=xi*(2.d0*xi-1.d0)
         ratio( 3)=et*(2.d0*et-1.d0)
         ratio( 4)=ze*(2.d0*ze-1.d0)
         ratio( 5)=4.d0*xi*a
         ratio( 6)=4.d0*xi*et
         ratio( 7)=4.d0*et*a
         ratio( 8)=4.d0*ze*a
         ratio( 9)=4.d0*xi*ze
         ratio(10)=4.d0*et*ze
      elseif(nterms.eq.15) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         if(xi+et.gt.1.d0) then
            dummy=xi
            xi=1.d0-et
            et=1.d0-dummy
         endif
!
         ze=zeg
         a=1.d0-xi-et
!
!     shape functions
!
         ratio(1)=-0.5d0*a*(1.d0-ze)*(2.d0*xi+2.d0*et+ze)
         ratio(2)=0.5d0*xi*(1.d0-ze)*(2.d0*xi-2.d0-ze)
         ratio(3)=0.5d0*et*(1.d0-ze)*(2.d0*et-2.d0-ze)
         ratio(4)=-0.5d0*a*(1.d0+ze)*(2.d0*xi+2.d0*et-ze)
         ratio(5)=0.5d0*xi*(1.d0+ze)*(2.d0*xi-2.d0+ze)
         ratio(6)=0.5d0*et*(1.d0+ze)*(2.d0*et-2.d0+ze)
         ratio(7)=2.d0*xi*a*(1.d0-ze)
         ratio(8)=2.d0*xi*et*(1.d0-ze)
         ratio(9)=2.d0*et*a*(1.d0-ze)
         ratio(10)=2.d0*xi*a*(1.d0+ze)
         ratio(11)=2.d0*xi*et*(1.d0+ze)
         ratio(12)=2.d0*et*a*(1.d0+ze)
         ratio(13)= a*(1.d0-ze*ze)
         ratio(14)=xi*(1.d0-ze*ze)
         ratio(15)=et*(1.d0-ze*ze)
      elseif(nterms.eq.20) then
         xi=xig
         et=etg
         ze=zeg
!
         omg=1.d0-xi
         omh=1.d0-et
         omr=1.d0-ze
         opg=1.d0+xi
         oph=1.d0+et
         opr=1.d0+ze
         tpgphpr=opg+oph+ze
         tmgphpr=omg+oph+ze
         tmgmhpr=omg+omh+ze
         tpgmhpr=opg+omh+ze
         tpgphmr=opg+oph-ze
         tmgphmr=omg+oph-ze
         tmgmhmr=omg+omh-ze
         tpgmhmr=opg+omh-ze
         omgopg=omg*opg/4.d0
         omhoph=omh*oph/4.d0
         omropr=omr*opr/4.d0
         omgmopg=(omg-opg)/4.d0
         omhmoph=(omh-oph)/4.d0
         omrmopr=(omr-opr)/4.d0
!
!     shape functions
!
         ratio( 1)=-omg*omh*omr*tpgphpr/8.d0
         ratio( 2)=-opg*omh*omr*tmgphpr/8.d0
         ratio( 3)=-opg*oph*omr*tmgmhpr/8.d0
         ratio( 4)=-omg*oph*omr*tpgmhpr/8.d0
         ratio( 5)=-omg*omh*opr*tpgphmr/8.d0
         ratio( 6)=-opg*omh*opr*tmgphmr/8.d0
         ratio( 7)=-opg*oph*opr*tmgmhmr/8.d0
         ratio( 8)=-omg*oph*opr*tpgmhmr/8.d0
         ratio( 9)=omgopg*omh*omr
         ratio(10)=omhoph*opg*omr
         ratio(11)=omgopg*oph*omr
         ratio(12)=omhoph*omg*omr
         ratio(13)=omgopg*omh*opr
         ratio(14)=omhoph*opg*opr
         ratio(15)=omgopg*oph*opr
         ratio(16)=omhoph*omg*opr
         ratio(17)=omropr*omg*omh
         ratio(18)=omropr*opg*omh
         ratio(19)=omropr*opg*oph
         ratio(20)=omropr*omg*oph
      else
         write(*,*) '*ERROR in distattach: case with ',nterms
         write(*,*) '       terms is not covered'
         call exit(201)
      endif
!
!     calculating the position in the face
!
      do i=1,3
         p(i)=0.d0
         do j=1,nterms
            p(i)=p(i)+ratio(j)*pneigh(i,j)
         enddo
      enddo
!
!     calculating the distance
!
      a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2
!
      return
      end


      real*8 function voigt(a,v)
c******************************************************************************
c     This routine calculates the voigt function using the approximations
c     found in the *new series-astronomy and astrophysics* volume of
c     landolt-bornstein.
c******************************************************************************

      implicit real*8 (a-h,o-z)
      a2 = a*a
      v2 = v*v
      if(a .eq. 0.) go to 62
      if(a .le. 0.2) go to 50
      if(a.le.1.4 .and. a+v.le.3.2) go to 30

c  case 1, a .gt. 1.4 or (a .gt. 0.2 and a+v .gt. 3.2)
      u = 1.4142136*(a2 + v2)
      voigt = 0.7978847*a/u*(1.0 + (3.0*v2-a2)/u**2 + (15.0*v2*v2
     1 -30.0*a2*v2+3.0*a2*a2)/u**4)
      voigt = voigt/1.772454
      return
30    u=0.979895023-0.962846325*a+0.532770573*a2-0.122727278*a*a2
31    h0 = dexp(-v2)
      if(v .ge. 2.4) go to 35
      if(v .ge. 1.3) go to 33

c  case 2,  0.2 .lt. a .le. 1.4 and a+v .le. 3.2
      h1=-1.12470432-0.15516677*v+3.28867591*v2-2.34357915*v*v2
     1 +0.42139162*v2*v2
      go to 36
33    h1=-4.48480194+9.39456063*v-6.61487486*v2+1.98919585*v*v2
     1 -0.2204165*v2*v2
      go to 36
35    h1=(0.554153432+0.278711796*v-0.188325687*v2+0.042991293*v*v2
     1 -0.003278278*v2*v2)/(v2 - 1.5)
36    h2 = (1.0 - 2.0*v2)*h0
      if(a .le. 0.2) go to 52
      h1 = h1 + 1.1283790*h0
      h2p = h2
      h2 = h2 - h0 + 1.1283790*h1
      h3 = 0.37612635*(1.0-h2p) - 0.6666667*v2*h1 + 1.1283790*h2
      h4 = 0.6666667*v2*v2*h0 - 0.37612635*h1 + 1.1283790*h3
      voigt = u*(h0 + h1*a + h2*a2 + h3*a*a2 + h4*a2*a2)
      voigt = voigt/1.772454
      return

c  case 3,  a .le. 0.2 and v .lt. 5.0
50    if(v .ge. 5.0) go to 60
      go to 31
52    voigt = h0 + h1*a + h2*a2
      voigt = voigt/1.772454
      return

c  case 4,  a .le. 0.2 and v .ge. 5.0
60    voigt = a/(1.772454*v2)*(1.0 + 1.5/v2 + 3.75/(v2*v2))
      voigt = voigt/1.772454
      return

c  case 5, a .eq. 0.0
62    voigt = exp(-v2)/1.772454

      return
      end


Real Function ptoe(srt)
  Parameter (pimass=0.140, etam=0.5475)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  s2 = srt**2
  ptoe = 1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
  Return
End Function ptoe


      SUBROUTINE SGAMI (A, X, PANS, QANS, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c
C>> 1998-10-29 SGAMI Krogh  Moved external statement up for mangle.
c>> 1996-03-30 SGAMI Krogh ALOG10 => CLOG10
c>> 1994-11-23 SGAMI CLL Added ?GR17 & ?GR29 to list of "c--" names.
c>> 1994-11-18 SGAMI WV Snyder del block data.  Change error reporting.
C>> 1994-11-03 SGAMI Krogh  Changed F90 do's to F77 do's.
C>> 1994-10-20 SGAMI Krogh  Changes to use M77CON
C>> 1994-05-09 SGAMI WVS JPL Make SP and DP from same source
C>> 1994-03-14 SGAMI WVS JPL Repair incomplete error message
C>> 1993-07-21 SGAMI WVS JPL Conversion from NSWC to Math 77
c--S replaces "?": ?GAMI, ?GAMIC, ?GAMIE, ?GAMIK, ?ERF, ?ERFC, ?ERFCE,
c--&               ?GAM1, ?RCOMP, ?RLOG, ?RLOG1, ?REXP, ?GAMIB,
c--&               ?GR17, ?GR29,  ?ERM1, ?ERV1
C ----------------------------------------------------------------------
C        Evaluation of the incomplete gamma function ratios
C        P(A,X) and Q(A,X), where P(A,X) = gamma(A,X)/GAMMA(A),
C        and P(A,X) + Q(A,X) = 1.
C
C                        ----------
C
C     IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X
C     ARE NOT BOTH 0.
C
C     PANS AND QANS ARE VARIABLES. SGAMI ASSIGNS PANS THE VALUE
C     P(A,X) AND QANS THE VALUE Q(A,X).
C
C     NORMAL RETURN ...
C
C        UPON NORMAL RETURN, BOTH OF PANS AND QANS WILL BE IN THE RANGE
C     [0.0 .. 1.0], PANS + QANS WILL BE WITHIN ROUND-OFF OF 1.0, AND
C     IERR = 0.
C
C     ERROR RETURN ...
C
C        PANS IS ASSIGNED THE VALUE 3 WHEN A AND X ARE BOTH ZERO AND THE
C     VALUE 4 WHEN ONE OR BOTH OF A OR X IS NEGATIVE.  IERR = INT(PANS)
C     WHEN PANS > 1.  IERR is assigned the value 2 if the desired error
c     was not achieved.
c
c     To set tolerances, CALL SGAMIK, q.v.  To discover the error
c     committed on the last call to SGAMI, CALL SGAMIE, q.v.
C
C ----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER, DAHLGREN, VIRGINIA
C     REVISED ... DEC 1991
c     See "Computation of the Incomplete Gamma Function", ACM TOMS 12, 4
c     (Dec 1986) 377-393.
C     Adapted to Math 77 by W. Van Snyder, JPL, 1993 May 5.
C ------------------------
      EXTERNAL SERF, SERFC, SERFCE, SGAM1
      EXTERNAL SRCOMP, SRLOG, srlog1, SREXP
      real             SERF, SERFC, SERFCE, SGAM1
      real             SRCOMP, SRLOG, srlog1, SREXP
C ------------------------
      real             A, X, PANS, QANS
      INTEGER IERR
      real             ACC, AMN, APN, A2N, A2NM1, B2N,
     *                 B2NM1, C, G, H, J, L, R, RTA, RTX, S,
     *                 SUM, T, TOL, TWOA, U,     W, Y, Z, WK(20)
      real             ACC0(5), BIG(5), E0(5), X0(5), X1(5)
      real             A0(4), A1(4), A2(2), A3(2), A4(2), A5(2),
     *                 A6(2), A7(2), A8(2)
      real             B0(6), B1(4), B2(5), B3(5), B4(4), B5(3),
     *                 B6(2), B7(2)
      real             C0, C1, C2, C3, C4, C5, C6, C7, C8
      real             D0(6), D1(4), D20, D2(2), D30, D3(2), D40, D4(1)
      real             D50, D5(1), D60, D6(1), D70, D80
      integer I, IOP, M, N
      real             E8, R30
      SAVE E8, R30
C ------------------------
      real             CLOG10, RT2PIN, RTPI, RTPIN
C     CLOG10 = LN(10)
C     RT2PIN = 1/SQRT(2*PI)
C     RTPI   = SQRT(PI)
C     RTPIN   = 1/SQRT(PI)
      PARAMETER (CLOG10=2.30258509299404568401799145468E0)
      PARAMETER (RT2PIN=.398942280401432677939946059935E0)
      PARAMETER (RTPI  =1.77245385090551602729816748334E0)
      PARAMETER (RTPIN =1.0E0 / RTPI)
C ------------------------
C     SOME OF THE TEMME COEFFICIENTS:
      real             D00, D01, D02, D03, D04, D10, D11, D12
      PARAMETER (D00 = - 1.0E0 / 3.0E0, D01 = 1.0E0 / 12.0E0)
      PARAMETER (D02 = -2.0E0 / 135.0E0, D03 = 1.0E0 / 864.0E0)
      PARAMETER (D04 = 1.0E0 / 2835.0E0)
      PARAMETER (D10 = -1.0E0 / 540.0E0, D11 = -1.0E0 / 288.0E0)
      PARAMETER (D12 = 1.0E0 / 378.0E0)
C --- COMMON /SGAMIC/ ---- (see SGAMIK for discussion)
C PQERR is approximately X * ABS(derivative of P(a,x) with respect to
c     X).  PQERR is used to estimate the error in P and Q due to
c     uncertainty in X:  Error in P or Q = PQERR * (relative error in
c     X).  When A and X are equal, PQERR = sqrt(A / (2*Pi) ).  Since P
c     and Q are bounded by 1, there can be no precision in the result if
c     A or X has relative error eps, and A > 2*Pi/eps**2.  If A and X
c     are not nearly equal, PQERR is small.
      real             PTOL, QTOL, XERR, PQERR, ROUND
      integer MSGOFF
      logical FIRST
      save FIRST
      common /SGAMIC/ PTOL, QTOL, XERR, PQERR, ROUND, MSGOFF
      save /SGAMIC/
      data FIRST /.TRUE./
C ------------------------
      data ACC0 / 5.0e-30, 5.0e-17, 5.0e-15, 5.0e-7, 5.0e-4 /
      data BIG / 50.0e0, 30.0e0, 25.0e0, 14.0e0, 10.0e0/
      data E0 / 0.0e0, 0.0e0, 0.25e-3, 0.25e-1, 0.14e0 /
      data X0 /68.0e0, 45.0e0, 31.0e0, 17.0e0, 9.7e0 /
      data X1 / 2.0e0, 2.0e0, 1.1e0, 1.1e0, 1.1e0 /
C ------------------------
C
C             COEFFICIENTS FOR MINIMAX APPROXIMATIONS
C                          FOR C0,...,C8
C
C ------------------------
      DATA A0(1) /-.231272501940775E-02/, A0(2)/-.335378520024220E-01/,
     *     A0(3) /-.159840143443990E+00/, A0(4)/-.333333333333333E+00/
      DATA B0(1)  /.633763414209504E-06/, B0(2)/-.939001940478355E-05/,
     *     B0(3)  /.239521354917408E-02/, B0(4)/ .376245718289389E-01/,
     *     B0(5)  /.238549219145773E+00/, B0(6)/ .729520430331981E+00/
C ------------------------
      DATA A1(1) /-.398783924370770E-05/, A1(2)/-.587926036018402E-03/,
     *     A1(3) /-.491687131726920E-02/, A1(4)/-.185185185184291E-02/
      DATA B1(1)  /.386325038602125E-02/, B1(2) /.506042559238939E-01/,
     *     B1(3)  /.283344278023803E+00/, B1(4) /.780110511677243E+00/
C ------------------------
      DATA A2(1)  /.669564126155663E-03/, A2(2) /.413359788442192E-02/
      DATA B2(1) /-.421924263980656E-03/, B2(2) /.650837693041777E-02/,
     *     B2(3) / .682034997401259E-01/, B2(4) /.339173452092224E+00/,
     *     B2(5) / .810647620703045E+00/
C ------------------------
      DATA A3(1)  /.810586158563431E-03/, A3(2) /.649434157619770E-03/
      DATA B3(1) /-.632276587352120E-03/, B3(2) /.905375887385478E-02/,
     *     B3(3) / .906610359762969E-01/, B3(4) /.406288930253881E+00/,
     *     B3(5) / .894800593794972E+00/
C ------------------------
      DATA A4(1) /-.105014537920131E-03/, A4(2)/-.861888301199388E-03/
      DATA B4(1)  /.322609381345173E-01/, B4(2) /.178295773562970E+00/,
     *     B4(3)  /.591353097931237E+00/, B4(4) /.103151890792185E+01/
C ------------------------
      DATA A5(1) /-.435211415445014E-03/, A5(2)/-.336806989710598E-03/
      DATA B5(1)  /.178716720452422E+00/, B5(2) /.600380376956324E+00/,
     *     B5(3)  /.108515217314415E+01/
C ------------------------
      DATA A6(1) /-.182503596367782E-03/, A6(2) /.531279816209452E-03/
      DATA B6(1)  /.345608222411837E+00/, B6(2) /.770341682526774E+00/
C ------------------------
      DATA A7(1)  /.443219646726422E-03/, A7(2) /.344430064306926E-03/
      DATA B7(1)  /.821824741357866E+00/, B7(2) /.115029088777769E+01/
C ------------------------
      DATA A8(1)  /.878371203603888E-03/, A8(2)/-.686013280418038E-03/
C ------------------------
C
C              COEFFICIENTS FOR THE TEMME EXPANSION
C
C ------------------------
      DATA D0(1) / D01 /, D0(2) / D02 /, D0(3) / D03 /, D0(4) / D04 /,
     *     D0(5) /-.178755144032922E-03/, D0(6) / .391926317852244E-04/
C ------------------------
      DATA D1(1) / D11 /, D1(2) / D12 /,
     *     D1(3) /-.990226337448560E-03/, D1(4) / .205761316872428E-03/
C ------------------------
      DATA D20   / .413359788359788E-02/, D2(1) /-.268132716049383E-02/,
     *     D2(2) / .771604938271605E-03/
C ------------------------
      DATA D30   / .649434156378601E-03/, D3(1) / .229472093621399E-03/,
     *     D3(2) /-.469189494395256E-03/
C ------------------------
      DATA D40   /-.861888290916712E-03/, D4(1) / .784039221720067E-03/
C ------------------------
      DATA D50   /-.336798553366358E-03/, D5(1) /-.697281375836586E-04/
C ------------------------
      DATA D60   / .531307936463992E-03/, D6(1) /-.592166437353694E-03/
C ------------------------
      DATA D70   / .344367606892378E-03/
C ------------------------
      DATA D80   /-.652623918595309E-03/
C ------------------------
C
      if (first) then
         first = .false.
         call SGAMIB
         call SGAMIK (0.0e0, 0.0e0, -1.0e0, 0)
         e8 = 8.0e0 * round
         r30 = max(round,1.0e-30)
      end if
c
      IF (A .EQ. 0.5E0) THEN
         IF (X .LT. 0.0E0) GO TO 510
c        Equation 8 in ref.
         RTX = SQRT(X)
         pqerr = rtx * rtpin * exp(-x)
         IF (X .LT. 0.25E0) THEN
            PANS = SERF(RTX)
            GO TO 395
         END IF
         QANS = SERFC(RTX)
         go to 390
      END IF
C
      acc = max(r30,min(abs(ptol),abs(qtol)))
      iop = 1
      do 150 n = 2, 5
         if (acc .ge. acc0(n)) iop = n
  150 continue
      acc = min(acc0(5),acc)
C
C              SELECT THE APPROPRIATE ALGORITHM
C
      IF (A .GE. 1.0E0) THEN
         IF (X .LT. 0.0E0) GO TO 510
         IF (X .EQ. 0.0E0) GO TO 300
         IF (A .LT. BIG(IOP)) THEN
            IF (A .LE. X .AND. X .LT. X0(IOP)) THEN
               TWOA = A + A
               M = TWOA
               IF (TWOA .EQ. M) THEN
C
C                 FINITE SUMS FOR Q WHEN A .GE. 1 AND 2*A IS AN INTEGER
c                 Equation 14 in ref.
C
                  I = M/2
                  T = EXP(-X)
                  C = A - I
                  IF (C .EQ. 0.0E0) THEN
                     SUM = T
                  ELSE
                     RTX = SQRT(X)
                     T = 2.0E0*T*RTX/RTPI
                     SUM = SERFC(RTX) + T
                  END IF
                  DO 160 N = 2, I
                     C = C + 1.0E0
                     T = (X*T)/C
                     SUM = SUM + T
  160             CONTINUE
                  pqerr = X * T
                  QANS = SUM
                  go to 390
               END IF
            END IF
         ELSE
C
            L = X/A
            IF (L .EQ. 0.0E0) GO TO 300
            if (l .le. 0.5e0) then
               s = (l - 0.5e0) - 0.5e0
               z = srlog(l)
            else
               s = x - a
               if (s + a .ne. x) then
c                 Exponents of S and A are different
                  if (x .gt. a) then
                     s = (0.5e0*x - a) + 0.5e0*x
                  else
                     s = (x - 0.5e0*a) - 0.5e0*a
                  end if
               end if
               s = s / a
               z = srlog1(s)
            end if
            rta = sqrt(a)
            if (z .ge. 700.0e0/a) GO TO 330
            Y = A*Z
            IF (ABS(S) .LE. 0.4E0) THEN
C
C                 MINIMAX APPROXIMATIONS
C
               U = 1.0E0/A
               Z = SQRT(Z + Z)
               IF (L .LT. 1.0E0) Z = -Z
               C = EXP(-Y)
               W = 0.5E0*SERFCE(SQRT(Y))
               IF (RTA*ABS(S) .GT. E0(IOP)) THEN
c                 Equations 17 in ref.
                  go to (210, 220, 230, 240, 250), iop
  210             continue
                     call sgr29 (z, u, t)
                     go to 290
c
  220             continue
                     call sgr17 (z, u, t)
                     go to 290
C
  230             IF (ABS(S) .LE. 1.0E-3) GO TO 260
C
C              USING THE MINIMAX APPROXIMATIONS
C
         C0 = (((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4)) / ((((((B0(1)*Z
     *     + B0(2))*Z + B0(3))*Z + B0(4))*Z + B0(5))*Z + B0(6))*Z + 1.0)
         C1 = (((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4)) /
     *     ((((B1(1)*Z + B1(2))*Z + B1(3))*Z + B1(4))*Z + 1.0)
         C2 = (A2(1)*Z + A2(2))/(((((B2(1)*Z + B2(2))*Z + B2(3))*Z +
     *     B2(4))*Z + B2(5))*Z + 1.0)
         C3 = (A3(1)*Z + A3(2))/(((((B3(1)*Z + B3(2))*Z + B3(3))*Z +
     *     B3(4))*Z + B3(5))*Z + 1.0)
         C4 = (A4(1)*Z + A4(2))/((((B4(1)*Z + B4(2))*Z + B4(3))*Z +
     *     B4(4))*Z + 1.0)
         C5 = (A5(1)*Z + A5(2))/(((B5(1)*Z + B5(2))*Z + B5(3))*Z + 1.0)
         C6 = (A6(1)*Z + A6(2))/((B6(1)*Z + B6(2))*Z + 1.0)
         C7 = (A7(1)*Z + A7(2))/((B7(1)*Z + B7(2))*Z + 1.0)
         C8 = A8(1)*Z + A8(2)
         T = (((((((C8*U + C7)*U + C6)*U + C5)*U + C4)*U + C3)*U +
     *                  C2)*U + C1)*U + C0
                  GO TO 290
C
C                 TEMME EXPANSION
C
  240             continue
                     C0 = (((((D0(6) * Z + D0(5)) * Z + D0(4)) * Z
     *                     + D0(3)) * Z + D0(2)) * Z + D0(1)) * Z + D00
                     C1 = (((D1(4) * Z + D1(3)) * Z + D1(2)) * Z
     *                     + D1(1)) * Z + D10
                     C2 = D2(1) * Z + D20
                     T  = (C2*U + C1)*U + C0
                     GO TO 290
C
  250             continue
                     T  = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00
                     GO TO 290
               END IF
C
C              TEMME EXPANSION FOR L = 1 (Equations 17-18 in ref).
c              (Can't get here if IOP = 1 or 2 because E0(1..2) = 0.0).
C
               IF (IOP - 4) 260,270,280
C
  260          C0 = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00
               C1 = ((D1(3) * Z + D1(2)) * Z + D1(1)) * Z + D10
               C2 = (D2(2) * Z + D2(1)) * Z + D20
               C3 = (D3(2) * Z + D3(1)) * Z + D30
               C4 = D4(1) * Z + D40
               C5 = D5(1) * Z + D50
               C6 = D6(1) * Z + D60
               T  = (((((((D80*U + D70)*U + C6)*U + C5)*U + C4)*U
     *                   + C3)*U + C2)*U + C1)*U + C0
               GO TO 290
C
  270          C0 = (D0(2) * Z + D0(1)) * Z + D00
               C1 = D1(1) * Z + D10
               T  = (D20*U + C1)*U + C0
               GO TO 290
C
  280          T  = D0(1) * Z + D00
C
  290          pqerr = C * RTA * RT2PIN
               IF (L .GE. 1.0E0) THEN
                  QANS = C*(W + RT2PIN*T/RTA)
                  GO TO 390
               END IF
               PANS = C*(W - RT2PIN*T/RTA)
               go to 395
            END IF
         END IF
C
         R = SRCOMP(A,X)
         IF (R .EQ. 0.0E0) GO TO 331
         pqerr = R * SQRT(A) * RT2PIN
         IF (X .LE. MAX(A,CLOG10)) THEN
C
C              TAYLOR SERIES FOR P/R (Equation 15 in ref.)
C
            APN = A + 1.0E0
            T = X/APN
            DO 51 N = 1, 20
               WK(N) = T
               APN = APN + 1.0E0
               T = T*(X/APN)
               IF (T .LE. 1.0E-3) GO TO 60
   51       CONTINUE
            N = 20
C
   60       SUM = T
            TOL = 0.5E0*ACC
   61       CONTINUE
               APN = APN + 1.0E0
               T = T*(X/APN)
               SUM = SUM + T
            IF (T .GT. TOL) GO TO 61
C
            DO 70 M = N, 1, -1
               SUM = SUM + WK(M)
   70       CONTINUE
            PANS = (R/A)*(1.0E0 + SUM)
            go to 395
         END IF
         IF (X .LT. X0(IOP)) GO TO 170
C
C              ASYMPTOTIC EXPANSION (Equation 15 in ref).
C
         AMN = A - 1.0E0
         T = AMN/X
         DO 81 N = 1, 20
            WK(N) = T
            AMN = AMN - 1.0E0
            T = T*(AMN/X)
            IF (ABS(T) .LE. 1.0E-3) GO TO 90
   81    CONTINUE
         N = 20
C
   90    SUM = T
   91    IF (ABS(T) .GE. ACC) THEN
            AMN = AMN - 1.0E0
            T = T*(AMN/X)
            SUM = SUM + T
            GO TO 91
         END IF
C
         DO 101 M = N, 1, -1
            SUM = SUM + WK(M)
  101    CONTINUE
         QANS = (R/X)*(1.0E0 + SUM)
         go to 390
      END IF
C
C     A .LT. 1.0 HERE
C
      IF (X .LT. X1(IOP)) THEN
         IF (A .LT. 0.0E0 .OR. X .LT. 0.0E0) GO TO 510
         IF (a*x .eq. 0.0E0) GO TO 320
C
C              TAYLOR SERIES FOR P(A,X)/X**A (Equations 9-10 in ref.)
C
         L = 3.0E0
         C = X
         SUM = X/(A + 3.0E0)
         TOL = 3.0E0*ACC/(A + 1.0E0)
  120    CONTINUE
            L = L + 1.0E0
            C = -C*(X/L)
            T = C/(A + L)
            SUM = SUM + T
         IF (ABS(T) .GT. TOL) GO TO 120
         J = A*X*((SUM/6.0E0 - 0.5E0/(A + 2.0E0))*X + 1.0E0/(A + 1.0E0))
C
         Z = A*LOG(X)
         H = SGAM1(A)
         G = 1.0E0 + H
         pqerr = A*SQRT(A)*EXP(Z-X)*RT2PIN
         U = EXP(Z)
c        Equation 9 in ref.
         PANS = U*G*(0.5E0 + (0.5E0 - J))
         IF (PANS .LE. 0.9E0) GO TO 395
         L = SREXP(Z)
c        Equation 10 in ref.
         QANS = MAX((U*J - L)*G - H, 0.0E0)
         go to 390
      END IF
C
C     A .LT. 1.0 AND X .GE. X1(IOP) here (BUT A .NE. 0.5)
C
      IF (A .LT. 0.0E0) GO TO 510
      IF (A .EQ. 0.0E0) GO TO 310
      R = SRCOMP(A,X)
      pqerr = R*SQRT(A)*RT2PIN
      IF (R .EQ. 0.0E0) GO TO 310
C
C              CONTINUED FRACTION EXPANSION (Equation 11 in ref.)
C              a .le. 1 and x .ge. 1.1, or 1 .le. a .le. big and
c              a .le. x .lt. x0, or a .gt. big and 7*a/5 .le. x .lt. x0.
C
  170 TOL = MAX(E8,4.0E0*ACC)
      B2N = X + (1.0E0 - A)
      B2NM1 = X / B2N
      A2NM1 = 1.0E0 / B2N
      A2N = A2NM1
      C = 1.0E0
  180 CONTINUE
         A2NM1 = X*A2N + C*A2NM1
         B2NM1 = X     + C*B2NM1
         C = C + 1.0E0
         T = C - A
         A2N = A2NM1 + T*A2N
         B2N = B2NM1 + T
C
         A2NM1 = A2NM1/B2N
         B2NM1 = B2NM1/B2N
         A2N = A2N/B2N
         IF (ABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 180
C
      QANS = R*A2N
      go to 390
C
C              SPECIAL CASES
C
  330 IF (A .EQ. X) THEN
         QANS = 0.5E0
         pqerr = RTA*RT2PIN
         go to 390
      END IF
C
  331 IF (X .GT. A) GO TO 310
C
C The error magnification factor is identically zero along both axes.
  300 PANS = 0.0E0
      QANS = 1.0E0
      pqerr = 0.0
      go to 400
C
  320 IF (A .NE. 0.0E0) GO TO 300
      IF (X .eq. 0.0E0) GO TO 500
C
  310 QANS = 0.0E0
      pqerr = 0.0
c
c              Check the error committed
c
  390 PANS = 0.5E0 + (0.5E0 - QANS)
      GO TO 400
  395 QANS = 0.5E0 + (0.5E0 - PANS)
  400 pqerr = pqerr * xerr
      if (pqerr .gt. 4.0e0 * round) then
         if (ptol .gt. 0.0) then
            if (pqerr .gt. ptol * pans) go to 520
         else
            if (pqerr .gt. -ptol) go to 520
         end if
         if (qtol .gt. 0.0) then
            if (pqerr .gt. qtol * qans) go to 520
         else
            if (pqerr .gt. -qtol) go to 520
         end if
      end if
      ierr = 0
      return
C
C              ERROR RETURNS
C
  500 CALL ERMSG ('SGAMI',3,2+msgoff,'A and X are both zero','.')
      PANS = 3.0
      IERR = 3
      RETURN
  510 CALL SERM1 ('SGAMI',4,2+msgoff,'One of A or X is negative','A',A,
     1            ',')
      CALL SERV1 ('X',X,'.')
      PANS = 4.0
      IERR = 4
      RETURN
  520 call serm1 ('SGAMI',2,2+msgoff,'Error tolerances not achieved',
     1            'Absolute error',pqerr,',')
      call serv1 ('PANS',pans,',')
      call serv1 ('PTOL',ptol,',')
      call serv1 ('QANS',qans,',')
      call serv1 ('QTOL',qtol,',')
      call serv1 ('A',a,',')
      call serv1 ('X',x,'.')
      ierr = 2
      return
      end

      subroutine SGAMIK (PTOLA, QTOLA, XERRA, MSGA)
c
c     Control SGAMI tolerances and error action.
c
c PTOLA and QTOLA are tolerances for PANS and QANS.  When negative they
c     are absolute tolerances; when positive they are relative
c     tolerances; when zero they mean use the default tolerance.  The
c     default is 4 times the round-off level.
c XERRA is the relative error in X.  Negative means use the default,
c     which is one round-off.
c MSGA is the message action offset, added onto the message level for
c     each message produced by SGAMI.
c
      real             PTOLA, QTOLA, XERRA
      integer MSGA
c
c ROUND is the round-off level.
c
      external R1MACH
      external SGAMIB
      real             R1MACH
c
c /SGAMIC/ is used to remember and communicate the tolerance, error and
c     message action settings.
c PTOL, QTOL are tolerances for PANS and QANS, set from PTOLA and QTOLA.
c XERR is the relative error in X, set from XERRA.
c PQERR is the absolute error in the last computation of P or Q, if any,
c     else it is -1.0.
c ROUND is the round-off level.
c MSGOFF is the message action offset.
c FIRST is .TRUE. iff SGAMIK has never been called.
c
      real             PTOL, QTOL, XERR, PQERR, ROUND
      integer MSGOFF
      logical FIRST
      save FIRST
      common /SGAMIC/ PTOL, QTOL, XERR, PQERR, ROUND, MSGOFF
      save /SGAMIC/
      data FIRST /.TRUE./
c
      if (first) then
         call sgamib
         round = r1mach(4)
         first = .false.
      end if
      if (ptola .eq. 0.0e0) then
         ptol = 4.0e0 * round
      else
         ptol = ptola
      end if
      if (qtola .eq. 0.0e0) then
         qtol = 4.0e0 * round
      else
         qtol = qtola
      end if
      if (xerra .lt. 0.0e0) then
         xerr = round
      else
         xerr = xerra
      end if
      msgoff = msga
      return
      end

      subroutine SGAMIE (PQERRV)
c
c     Return the error committed on the last call to SGAMI, if any, else
c     return -1.0
c
      real             PQERRV
      real             PTOL, QTOL, XERR, PQERR, ROUND
      integer MSGOFF
      logical FIRST
      save FIRST
      common /SGAMIC/ PTOL, QTOL, XERR, PQERR, ROUND, MSGOFF
      save /SGAMIC/
      data FIRST /.TRUE./
      if (first) then
        call sgamib
        first = .false.
      end if
      pqerrv = pqerr
      return
      end

      subroutine SGAMIB
      real             PTOL, QTOL, XERR, PQERR, ROUND
      integer MSGOFF
      logical FIRST
      save FIRST
      common /SGAMIC/ PTOL, QTOL, XERR, PQERR, ROUND, MSGOFF
      save /SGAMIC/
      data FIRST /.TRUE./
      if (first) then
        PQERR = -1.0e0
        first = .false.
      end if
      end


Real Function xop2oe(srt)
  Parameter (pimass=0.140, etam=0.5475, aomega=0.782)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  s2 = srt**2
  pf2 = (s2-(aomega+etam)**2)*(s2-(aomega-etam)**2)/2/sqrt(s2)
  pi2 = (s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
  xop2oe = 1./3.*pf2/pi2*xoe2op(srt)
  Return
End Function xop2oe


!
! Metric reconstruction evolution equations
!
!=============================================================================
module mod_metric_recon
!=============================================================================
   use mod_prec

   use mod_cheb,     only: R=>Rarr, compute_DR
   use mod_field,    only: field, set_level
   use mod_ghp,      only: set_edth, set_edth_prime, set_thorn, set_thorn_prime
   use mod_bkgrd_np, only: mu_0, ta_0, pi_0, rh_0, psi2_0
   use mod_params,   only: &
      dt, nx, ny, min_m, max_m, &
      cl=>compactification_length, &
      bhm=>black_hole_mass

   use mod_fields_list, only: &
      psi4_lin_f, &
      psi3, psi2,         &
      la, pi,             &
      muhll, hlmb, hmbmb, &
      res_bianchi3, res_bianchi2, res_hll
!=============================================================================
   implicit none
   private

   public :: &
      metric_recon_time_step_preserve_m_ang, &
      metric_recon_time_step_mix_m_ang, &
      metric_recon_indep_res
!=============================================================================
   contains
!=============================================================================
   subroutine set_k(step, m_ang, f, kl)
      integer(ip),  intent(in) :: step, m_ang
      type(field), intent(inout) :: f
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: kl
      !----------------------------------------------------------------------
      call set_level(step, m_ang, f)
      !----------------------------------------------------------------------
      select_field: select case (f%fname)
         !-------------------------------------------------------------------
         case ("psi3")
            kl(:,:,m_ang) = &
            -  4.0_rp*R*mu_0*f%level(:,:,m_ang) &

            -  R*ta_0*(psi4_lin_f%level(:,:,m_ang)) &

            +  (psi4_lin_f%edth(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("la")
            kl(:,:,m_ang) = &
            -  R*( &
                  mu_0 &
               +  conjg(mu_0) &
               )*f%level(:,:,m_ang) &

            - (psi4_lin_f%level(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("psi2")
            kl(:,:,m_ang) = &
            -  3.0_rp*R*mu_0*f%level(:,:,m_ang) &

            -  2.0_rp*R*ta_0*(psi3%level(:,:,m_ang)) &

            +  (psi3%edth(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("hmbmb")
            kl(:,:,m_ang) = &
               R*( &
                  mu_0 &
               -  conjg(mu_0) &
               )*f%level(:,:,m_ang) &

            -  2.0_rp*(la%level(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("pi")
            kl(:,:,m_ang) = &
            -  R*( &
                  conjg(pi_0) &
               +  ta_0 &
               )*(la%level(:,:,m_ang)) &

            +  (R**2)*0.5_rp*mu_0*( &
                  conjg(pi_0) &
               +  ta_0 &
               )*(hmbmb%level(:,:,m_ang)) &
            -  (psi3%level(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("hlmb")
               kl(:,:,m_ang) = &
               -  R*conjg(mu_0)*f%level(:,:,m_ang) &

               -  2.0_rp*(pi%level(:,:,m_ang)) &

               -  R*ta_0*(hmbmb%level(:,:,m_ang))
         !--------------------------------------------------------------------
         case ("muhll")
            kl(:,:,m_ang) = &
            -  R*conjg(mu_0)*f%level(:,:,m_ang) &

            -  R*mu_0*(hlmb%edth(:,:,m_ang)) &

            -  (R**2)*mu_0*( &
                  conjg(pi_0) &
               +  2.0_rp*ta_0 &
               )*(hlmb%level(:,:,m_ang)) &

            -  2.0_rp*(pi%edth(:,:,m_ang)) &

            -  2.0_rp*R*conjg(pi_0)*(pi%level(:,:,m_ang)) &

            -  2.0_rp*(psi2%level(:,:,m_ang)) &
            !
            ! complex conjugate of fields
            !
            -  2.0_rp*R*pi_0*conjg(pi%level(:,:,-m_ang)) &

            -  R*pi_0*conjg(hmbmb%edth(:,:,-m_ang)) &

            +  (R**2)*(pi_0**2)*conjg(hmbmb%level(:,:,-m_ang)) &

            +  R*mu_0*conjg(hlmb%edth(:,:,-m_ang))  &

            +  (R**2)*( &
               -  3.0_rp*mu_0*pi_0 &
               +  2.0_rp*conjg(mu_0)*pi_0 &
               -  2.0_rp*mu_0*conjg(ta_0) &
               )*conjg(hlmb%level(:,:,-m_ang))
         !--------------------------------------------------------------------
         case default
            write (*,*) "ERROR: set_k, " // f%fname // ", not in list"
            stop
      end select select_field
      !-----------------------------------------------------------------------
      call compute_DR(step, m_ang, f)

      kl(:,:,m_ang) = ( &
            kl(:,:,m_ang) &

         -  ((R/cl)**2)*f%DR(:,:,m_ang) &

         -  (f%falloff*R/(cl**2))*f%level(:,:,m_ang) &
         )/( &
            2.0_rp+(4.0_rp*bhm*R/(cl**2)) &
         )

   end subroutine set_k
!=============================================================================
! RK4 evolution
!=============================================================================
   subroutine take_step(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f
      !-----------------------------------------------------------------------
      select_step: select case (step)
         !--------------------------------------------------------------------
         case (1)
            !--------------------------------------------------------
            ! if first time then k1 has not been set from k5
            !--------------------------------------------------------
            if (f%first_time) then
               call set_k(step, m_ang, f, f%k1)

               f%first_time = .false.
            end if

            f%l2(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k1(:,:,m_ang)
         !--------------------------------------------------------------------
         case (2)
            call set_k(step, m_ang, f, f%k2)

            f%l3(:,:,m_ang)= f%n(:,:,m_ang)+0.5_rp*dt*f%k2(:,:,m_ang)
         !--------------------------------------------------------------------
         case (3)
            call set_k(step, m_ang, f, f%k3)

            f%l4(:,:,m_ang)= f%n(:,:,m_ang)+dt*f%k3(:,:,m_ang)
         !--------------------------------------------------------------------
         case (4)
            call set_k(step, m_ang, f, f%k4)

            f%np1(:,:,m_ang)= f%n(:,:,m_ang) &
            +  (dt/6.0_rp)*(f%k1(:,:,m_ang)+2.0_rp*f%k2(:,:,m_ang)+2.0_rp*f%k3(:,:,m_ang)+f%k4(:,:,m_ang))
         !--------------------------------------------------------------------
         case (5)
            !-----------------------------------------------------------------
            ! need k5 for source term and independent residual
            !-----------------------------------------------------------------
            call set_k(step, m_ang, f, f%k5)
         !--------------------------------------------------------------------
         case default
            write(*,*) "Error: take_step, " // f%fname // ", step != 1,..,5"
            stop
      end select select_step
      !-----------------------------------------------------------------------
   end subroutine take_step
!=============================================================================
   subroutine set_indep_res(m_ang, fname)
      integer(ip),  intent(in) :: m_ang
      character(*), intent(in) :: fname
      !-----------------------------------------------------------------------
      select_field: select case (fname)
         !--------------------------------------------------------------------
         case ("res_bianchi3")

            call set_level(5_ip,m_ang,psi4_lin_f)
            call set_level(5_ip,m_ang,psi3)
            call set_level(5_ip,m_ang,la)

            call set_thorn(     5_ip,m_ang,psi4_lin_f)
            call set_edth_prime(5_ip,m_ang,psi3)
            !-----------------------------------------------
            res_bianchi3%np1(:,:,m_ang) = &
               R*psi3%edth_prime(:,:,m_ang) &

            +  4.0_rp*(R**2)*pi_0*psi3%level(:,:,m_ang) &

            -  psi4_lin_f%thorn(:,:,m_ang) &

            +  rh_0*psi4_lin_f%level(:,:,m_ang) &

            -  3.0_rp*(R**2)*psi2_0*la%level(:,:,m_ang)
         !--------------------------------------------------------------------
         case ("res_bianchi2")

            call set_level(5_ip,m_ang,pi)

            call set_level(5_ip,m_ang,psi2)
            call set_level(5_ip,m_ang,psi3)

            call set_level(5_ip,m_ang,hlmb)
            call set_level(5_ip,m_ang,hmbmb)

            call set_thorn(     5_ip,m_ang,psi3)
            call set_edth_prime(5_ip,m_ang,psi2)
            !-----------------------------------------------
            res_bianchi2%np1(:,:,m_ang) = &
               psi2_0*( &
               -  3.0_rp*(R**3)*mu_0*hlmb%level(:,:,m_ang) &
               -  1.5_rp*(R**3)*ta_0*hmbmb%level(:,:,m_ang) &
               -       3.0_rp*(R**2)*pi%level(:,:,m_ang) &
               ) &

            -  R*psi2%edth_prime(:,:,m_ang) &

            -  3.0_rp*(R**2)*pi_0*psi2%level(:,:,m_ang) &

            +  psi3%thorn(:,:,m_ang) &

            -  2.0_rp*rh_0*psi3%level(:,:,m_ang)
         !--------------------------------------------------------------------
         ! hll should be real
         !--------------------------------------------------------------------
         case ("res_hll")

            call set_level(5_ip,-m_ang,muhll)
            call set_level(5_ip, m_ang,muhll)
            !-----------------------------------------------
            res_hll%np1(:,:,m_ang) = &
                    (muhll%level(:,:, m_ang) / mu_0) &
            -  conjg(muhll%level(:,:,-m_ang) / mu_0)
         !--------------------------------------------------------------------
         case default
            continue
      end select select_field
   end subroutine set_indep_res
!=============================================================================
   subroutine step_all_fields_preserve_m_ang(step, m_ang)
      integer(ip), intent(in) :: step, m_ang
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,psi4_lin_f)
      call set_edth( step,m_ang,psi4_lin_f)

      call take_step(step,m_ang,psi3)
      call take_step(step,m_ang,la)
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,psi3)
      call set_edth( step,m_ang,psi3)

      call take_step(step,m_ang,psi2)
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,la)

      call take_step(step,m_ang,hmbmb)
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,hmbmb)

      call take_step(step,m_ang,pi)
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,pi)

      call take_step(step,m_ang,hlmb)
   end subroutine step_all_fields_preserve_m_ang
!=============================================================================
! evolve +/- m_ang as muhll requires both
!=============================================================================
   subroutine step_all_fields_mix_m_ang(step, m_ang)
      integer(ip), intent(in) :: step, m_ang
      !-----------------------------------------------------------------------
      call set_level(step,m_ang,   pi)
      call set_level(step,m_ang, psi2)
      call set_level(step,m_ang, hlmb)
      call set_level(step,m_ang,hmbmb)

      call set_edth(step,m_ang,   pi)
      call set_edth(step,m_ang, hlmb)
      call set_edth(step,m_ang,hmbmb)

      if (m_ang>0) then
         call set_level(step,-m_ang,   pi)
         call set_level(step,-m_ang, psi2)
         call set_level(step,-m_ang, hlmb)
         call set_level(step,-m_ang,hmbmb)

         call set_edth(step,-m_ang,   pi)
         call set_edth(step,-m_ang, hlmb)
         call set_edth(step,-m_ang,hmbmb)

         call take_step(step, m_ang,muhll)
         call take_step(step,-m_ang,muhll)
      else
         call take_step(step, m_ang,muhll)
      end if

   end subroutine step_all_fields_mix_m_ang
!=============================================================================
! evolve +/- m angular number fields
!=============================================================================
   subroutine metric_recon_time_step_preserve_m_ang(m_ang)
      integer(ip), intent(in) :: m_ang

      call step_all_fields_preserve_m_ang(1_ip,m_ang);
      call step_all_fields_preserve_m_ang(2_ip,m_ang);
      call step_all_fields_preserve_m_ang(3_ip,m_ang);
      call step_all_fields_preserve_m_ang(4_ip,m_ang);
      call step_all_fields_preserve_m_ang(5_ip,m_ang);

   end subroutine metric_recon_time_step_preserve_m_ang
!=============================================================================
   subroutine metric_recon_time_step_mix_m_ang(m_ang)
      integer(ip), intent(in) :: m_ang

      call step_all_fields_mix_m_ang(1_ip,m_ang);
      call step_all_fields_mix_m_ang(2_ip,m_ang);
      call step_all_fields_mix_m_ang(3_ip,m_ang);
      call step_all_fields_mix_m_ang(4_ip,m_ang);
      call step_all_fields_mix_m_ang(5_ip,m_ang);

   end subroutine metric_recon_time_step_mix_m_ang
!=============================================================================
   subroutine metric_recon_indep_res(m_ang)
      integer(ip), intent(in) :: m_ang

      call set_indep_res(m_ang,"res_bianchi3")
      call set_indep_res(m_ang,"res_bianchi2")
      call set_indep_res(m_ang,"res_hll")

   end subroutine metric_recon_indep_res
!=============================================================================
end module mod_metric_recon


c###geom.for
      SUBROUTINE GEOM
C--------------------------------
C
C     THIS ROUTINE CALCULATES THE PATH GEOMETRY
C
C MAPIN IS -1,IF DATA TAPE HAS NOT BEEN READ.
      common /Cnorth_pole/ g_magnetic_lat,g_magnetic_lon  !  magnetic north pole
C
      COMMON / ALPHA / IMON(12), ITRAN(2), IRCVR(2), LBMAP(2), MODE(13),
     A MODER(13), ITLAT, ITLONG, IRLAT, IRLONG, IRLATU, IRLONGU, NYEAR
      CHARACTER IMON*3, NYEAR*5, ITRAN*10, IRCVR*10, LBMAP*10, ITLAT*1,
     A ITLONG*1, IRLAT*1, IRLONG*1, IRLATU*1, IRLONGU*1, MODE*2, MODER*2
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON/GEOG/ GYZ(5), RAT(5), GMDIP(5), CLCK(5), ABIY(5), ARTIC(5),
     1 SIGPAT(5), EPSPAT(5)
      COMMON / OUTLAB / LABEL(11), LAYTYP(5), IEAST, INORTH, ISOUTH,
     A IWEST, LABLI, LABLJ, LABLK
      CHARACTER IEAST*1, ISOUTH*1, INORTH*1, IWEST*1, LABEL*5, LAYTYP*2,
     A LABLI*5, LABLJ*5, LABLK*5
      DATA EPSLON/1.E-7/
      data ddx/.03/      !  closest Tx & Rx can be
C.....RADIUS OF THE EARTH (RZ)
      BK = R2D
      AK = D2R
C.....GEOMAGNETIC NORTH POLE, LATITUDE, LONGITUDE, MINIMUM
C.....TAKE OFF ANGLE SERVICE PROBABILITY FACTOR
C.....LATITUDE SOUTH IS "-" AND LATITUDE NORTH IS "+"
C.....LONGITUDE EAST IS "+" AND LONGITUDE WEST IS "-"
ccc      GLT = 78.5 * D2R
ccc      GLG = -69.0 * D2R
      GLT = g_magnetic_lat * D2R      !  see routine set_magnetic_pole
      GLG = g_magnetic_lon * D2R
      if(abs(tlatd-rlatd).le.ddx .and. abs(tlongd-rlongd).le.ddx) then
c          move Rx away from Tx a little bit
         dd=ddx
         if(rlatd.lt.0.) dd=-ddx
         rlatd=tlatd-dd
      end if
      TLAT = TLATD * D2R
      TLONG = TLONGD * D2R
      RLAT = RLATD * D2R
      RLONG = RLONGD * D2R
      if(abs(rlatd).gt.89.9) rlong=0.     !  at poles, force long=0
      if(abs(tlatd).gt.89.9) tlong=0.     !  at poles, force long=0
C     GREAT CIRCLE DISTANCE AND BEARINGS.
 100  DLONG = TLONG - RLONG
      IF (ABS (DLONG) .GT. PI) DLONG = DLONG - SIGN (PI2, DLONG)
C.....FOR LONG GREAT CIRCLE PATH
      IF (NPSL .EQ. 1) DLONG = DLONG - SIGN (PI2, DLONG)
      QCOS=SIN(TLAT)*SIN(RLAT)+COS(TLAT)*COS(RLAT)*COS(DLONG)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      GCD = ACOS (QCOS)
C.....MINIMUM DISTANCE IS 31.85 METERS
      IF(GCD.LT.0.000001) GCD = 0.000001
C.....FOR GREAT CIRCLE PATH
      IF (NPSL .EQ. 1) GCD = PI2 - GCD
      GCDKM = GCD * RZ
C.....CHECK IF TRANSMITTER IS NEAR A POLE
      IF(COS(TLAT) - EPSLON) 101, 101, 104
C.....TRANSMITTER IS NEAR A POLE
  101 IF (TLAT) 102,102,103
  102 BTR= 0.0
      GO TO 106
  103 BTR = PI
      GO TO 106
C.....TRANSMITTER IS NOT NEAR A POLE
  104 CONTINUE
      QCOS=(SIN(RLAT)-SIN(TLAT)*COS(GCD))/(COS(TLAT)*SIN(GCD))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....BTR IS BEARING, TRANSMITTER TO RECEIVER
      BTR = ACOS (QCOS)
  106 CONTINUE
      IF (DLONG .GT. 0.0) BTR = PI2 - BTR
C.....CHECK IF RECEIVER IS NEAR A POLE
      IF(COS(RLAT) - EPSLON) 111, 111, 114
C.....RECEIVER IS NEAR A POLE
  111 IF( RLAT )  112,112,113
  112 BRT = 0.
      GO TO 116
  113 BRT=PI
      GO TO 116
C.....RECEIVER IS NOT NEAR A POLE
  114 CONTINUE
      QCOS=(SIN(TLAT)-SIN(RLAT)*COS(GCD))/(COS(RLAT)*SIN(GCD))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....BRT IS BEARING, RECEIVER TO TRANSMITTER
      BRT = ACOS (QCOS)
  116 CONTINUE
      IF (DLONG .LT. 0.0) BRT = PI2 - BRT
C.....CONVERT BEARINGS TO DEGREES
      BTRD = BTR * R2D
      BRTD = BRT * R2D
C     DETERMINATION OF REFLECTION AREAS.
C SELECT SAMPLE AREAS IN ORDER
      IF(GCDKM.le.2000.01) then
C.....KM IS THE NUMBER OF SAMPLE AREAS
         KM=1
         RD(1)= GCD/2.
      else if(GCDKM.le.4000.) then
         KM=3
         RD(1) = 1000. / RZ
         RD(2)= GCD/2.
         RD(3)= GCD -RD(1)
      else
         KM= 5
         RD(1) = 1000. / RZ
         RD(2)= RD(1)+RD(1)
         RD(3)= GCD/2.
         RD(4)= GCD-RD(2)
         RD(5)= GCD-RD(1)
      end if
ccc      write(12,'(''in geom, km='',i5,f10.2)') km,gcdkm
C.....RD(1) IS E LAYER, RD(2) IS F LAYER, RD(3) IS ALL LAYERS,
C.....RD(4) IS F LAYER AND RD(5) IS E LAYER
C     REFLECTION AREA COORDINATES AND GEOMAGNETIC LATITUDE.
66    IF(KM.LT.1) GO TO 185
      DO 180 I = 1, KM
      DRF = RD (I)
      CTLAT = COS(TLAT)
C.....CHECK IF TRANSMITTER IS NEAR A POLE
      IF(CTLAT - EPSLON) 71, 76, 76
C.....TRANSMITTER IS NEAR A POLE
   71 RFLT = TLAT - SIGN(DRF,TLAT)
      IF(ABS(RFLT).gt.PIO2) RFLT=PIO2*sign(1.,RFLT)
      RFLG=RLONG
      GO TO 80
C.....TRANSMITTER IS NOT NEAR A POLE
   76 CONTINUE
      QCOS=COS(DRF)*SIN(TLAT)+SIN(DRF)*COS(TLAT)*COS(BTR)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      RFLT = PIO2 - ACOS (QCOS)
C.....CHECK IF THE SAMPLE AREA IS NEAR A POLE
      IF(COS(RFLT) - EPSLON) 78, 78, 79
C.....SAMPLE AREA IS NEAR A POLE
   78 RFLG = TLONG
      GO TO 80
C.....SAMPLE AREA IS NOT NEAR A POLE
   79 CONTINUE
      QCOS=(COS(DRF)-SIN(RFLT)*SIN(TLAT))/(COS(RFLT)*COS(TLAT))
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
      RFLG = ACOS (QCOS)
      IF (DRF .GE. PI) RFLG = PI2 - RFLG
      RFLG = TLONG - SIGN (RFLG, DLONG)
      IF (ABS (RFLG) .GT. PI) RFLG = RFLG - SIGN (PI2, RFLG)
   80 CONTINUE
      QCOS=SIN(GLT)*SIN(RFLT)+COS(GLT)*COS(RFLT)*COS(RFLG-GLG)
      IF (ABS (QCOS) .GT. 1.0) QCOS = SIGN (1.0, QCOS)
C.....GLAT(I) IS THE GEOMAGNETIC LATITUDE
C.....CLAT(I) IS THE GEOGRAPHIC LATITUDE
C.....CLONG(I) IS THE GEOGRAPHIC LONGITUDE
      GAT = ACOS (QCOS)
      GLAT (I) = PIO2 - GAT
      CLAT (I) = RFLT
      CLONG (I) = RFLG
C.....MAGNETIC FIELD VARIABLES.
C....CLG IS THE GEOGRAPHIC EAST LONGITUDE(SAVED FOR CALL TO NOISY)
      CLG = RFLG
      CALL MAGVAR(RFLT,RFLG,I,CLG)
C.....CHECK TO SEE IF MAP AVAILABLE IS CONSISTANT WITH BEARING
ccc      IF(MAPIN.le.0) go to 115
C.....OBTAIN LAND MASS MAP
         RFLTD = RFLT * R2D
         CLGD = CLG * R2D
         IF(CLGD.LT.0.)CLGD=CLGD+360.
         CALL NOISY(7,RFLTD,CLGD,WLD)
      IF(WLD.ge.0) go to 115
C.....GROUND CONSTANTS FOR SEA
         SIGPAT (I) = 5.
         EPSPAT (I) = 80.
         go to 120
C.....GROUND CONSTANTS FOR LAND
115      SIGPAT (I) = 0.001
         EPSPAT (I) = 4.
 120  CONTINUE
  180 CONTINUE
 185  CONTINUE
      ALATD=ABS(CLAT(1))*R2D
      IF(KM.NE.1) ALATD=ABS((CLAT(1)+CLAT(2)+CLAT(3))/3.0)*R2D
ccc      write(12,'(''glat='',5e15.7)') (glat(i),i=1,km)
      RETURN
      END
C--------------------------------


!! R439 component-array-spec
!    is explicit-shape-spec-list
!    or deferred-shape-spec-list
!
INTEGER, PARAMETER :: a = 3, x = 4, y = 13
type ugly
  REAL, pointer :: truth(:)
  REAL, POINTER :: beauty(:,:,:,:,:)
  integer :: foo(2,3,4,a,x)
  REAL :: bar(y)
  real lies(8)
END TYPE
END PROGRAM