c
c      This file contains the basic subroutines for
c      forming and evaluating multipole (partial wave) expansions.
c
c
c      Remarks on scaling conventions.
c
c      1)  Hankel and Bessel functions are consistently scaled as
c       	hvec(n)= h_n(z)*scale^(n)
c       	jvec(n)= j_n(z)/scale^(n)
c
c          scale should be of the order of |z| if |z| < 1. Otherwise,
c          scale should be set to 1.
c
c
c      2) There are many definitions of the spherical harmonics,
c         which differ in terms of normalization constants. We
c         adopt the following convention:
c
c         For m>0, we define Y_n^m according to
c
c         Y_n^m = \sqrt{2n+1} \sqrt{\frac{ (n-m)!}{(n+m)!}} \cdot
c                 P_n^m(\cos \theta)  e^{i m phi}
c         and
c
c         Y_n^-m = dconjg( Y_n^m )
c
c         We omit the Condon-Shortley phase factor (-1)^m in the
c         definition of Y_n^m for m<0.
c
c         We also omit the factor \sqrt{\frac{1}{4 \pi}}, so that
c         the Y_n^m are orthogonal on the unit sphere but not
c         orthonormal.
c         More precisely,
c
c                 \int_S Y_n^m Y_n^m d\Omega = 4 \pi.
c
c         Using our standard definition, the addition theorem takes
c         the simple form
c
c         e^( i k r}/(ikr) =
c         \sum_n \sum_m  j_n(k|S|) Y_l^m*(S) h_n(k|T|) Y_l^m(T)
c
c
c-----------------------------------------------------------------------
c
c      h3dmpevalp: computes potential
c                 due to a multipole expansion
c                 at a collection of targets.
c
c      h3dmpevalg: computes potential and gradients
c                          due to a multipole expansion
c                          at a collection of targets
c
c      h3dformmpc: creates multipole expansion due to
c                 a collection of charges
c
c      h3dformmpd: creates multipole expansion due to
c                 a collection of dipoles
c
c      h3dformmpcd: creates multipole expansion due
c                                to a collection of charges
c                                and dipoles
c
c      h3dtaevalp: computes potential
c                 due to a local expansion
c                 at a collection of targets.
c
c      h3dtaevalg: computes potential and gradients
c                          due to a local expansion
c                          at a collection of targets
c
c      h3dformtac: creates local expansion due to
c                 a collection of charges
c
c      h3dformtad: creates local expansion due to
c                 a collection of dipoles
c
c      h3dformtacd: creates local expansion due
c                                to a collection of charges
c                                and dipoles
c
c**********************************************************************
      subroutine h3dmpevalp(nd,zk,rscale,center,mpole,nterms,ztarg,
     1            ntarg,pot,wlege,nlege,thresh)
c**********************************************************************
c
c     This subroutine evaluates the potential
c     of an outgoing partial wave expansion and adds to existing
c     quantities.
c
c     pot = pot + sum sum  mpole(n,m) h_n(k r) Y_nm(theta,phi)
c                  n   m
c
c      If r < thresh
c          then the subroutine does not update the potential
c          (recommended value = boxsize(0)*machine precision
c           where boxsize(0) is the size of the computation domain)
c
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     zk     :    Helmholtz parameter
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    multipole expansion in 2d matrix format
c     nterms :    order of the multipole expansion
c     ztarg  :    target locations
c     ntarg  :    number of targets
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c     thresh :    threshold for computing outgoing expansion,
c                 potential at target won't be updated if
c                 |t - c| <= thresh, where t is the target
c                 location and, and c is the expansion center
c                 location
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :    updated potential at ztarg
c
c-----------------------------------------------------------------------
      implicit none
c
cc      calling sequence variables
c
      integer ntarg,nterms,nlege,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      complex *16 zk,pot(nd,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(*),thresh

c
cc      temporary variables
c
      integer idim
      complex *16, allocatable :: ephi(:),fhs(:)
      real *8, allocatable :: ynm(:,:)
      real *8 zdiff(3),done
      real *8 ctheta,stheta,r,theta,phi,cphi,sphi
      complex *16 ephi1,ur,utheta,uphi
      complex *16 eye
      complex *16 ztmp1,ztmp2,ztmp3,ztmpsum,z
      complex *16 fhder
      integer itarg,i,m,n,ifder
      data eye/(0.0d0,1.0d0)/

      done = 1
      ifder = 0

      allocate(ephi(-nterms-1:nterms+1))
      allocate(fhs(0:nterms))
      allocate(ynm(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta= dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
        if (r.lt.thresh)  goto 1000
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms+1
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions:
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
c
c
c     get the Hankel functions:
c
        z=zk*r
        call h3dall(nterms,z,rscale,fhs,ifder,fhder)

        do idim=1,nd
          pot(idim,itarg)=pot(idim,itarg)+mpole(idim,0,0)*fhs(0)
        enddo
        do n=1,nterms
          ztmp1 = fhs(n)*ynm(n,0)
          do idim=1,nd
   	        pot(idim,itarg)=pot(idim,itarg)+mpole(idim,n,0)*ztmp1
          enddo
          do m=1,n
	        ztmp1=fhs(n)*ynm(n,m)
            do idim=1,nd
	          ztmp2 = mpole(idim,n,m)*ephi(m)
	          ztmp3 = mpole(idim,n,-m)*ephi(-m)
	          ztmpsum = ztmp2+ztmp3
              pot(idim,itarg)=pot(idim,itarg)+ztmp1*ztmpsum
            enddo
          enddo
        enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine h3dmpevalg(nd,zk,rscale,center,mpole,nterms,ztarg,
     1            ntarg,pot,grad,wlege,nlege,thresh)
c**********************************************************************
c
c     This subroutine evaluates the potential, and gradient
c     of an outgoing partial wave expansion and adds to existing
c     quantities.
c
c     pot = pot + sum sum  mpole(n,m) h_n(k r) Y_nm(theta,phi)
c                  n   m
c
c     grad = grad + Gradient( sum sum  mpole(n,m) h_n(k r) Y_nm(theta,phi))
c                              n   m
c      If r < thresh
c          then the subroutine does not update the potential and gradient
c          (recommended value = boxsize(0)*machine precision
c            where boxsize(0) is the size of the computational domain)
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     zk     :    Helmholtz parameter
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    multipole expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target locations
c     ntarg  :    number of targets
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c     thresh :    threshold for computing outgoing expansion,
c                 potential at target won't be updated if
c                 |t - c| <= thresh, where t is the target
c                 location and, and c is the expansion center
c                 location
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :    updated potential at ztarg
c     grad    :   updated gradient at ztarg
c
c-----------------------------------------------------------------------
      implicit none
c
cc      calling sequence variables
c
      integer ntarg,nterms,nlege,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      complex *16 zk,pot(nd,ntarg),grad(nd,3,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(*),thresh

c
cc      temporary variables
c
      complex *16, allocatable :: ephi(:),fhs(:),fhder(:)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      real *8 zdiff(3),done
      real *8 r, theta,phi,ctheta,stheta,cphi,sphi
      real *8 rx,ry,rz
      real *8 phix,phiy,phiz
      real *8 thetax,thetay,thetaz,dtmp
      complex *16 ephi1,ur(nd),utheta(nd),uphi(nd)
      complex *16 eye
      complex *16 ztmp1,ztmp2,ztmp3,ztmpsum,z
      complex *16 ztmp4,ztmp5,ztmp6
      integer itarg,i,m,n,ifder,idim
      data eye/(0.0d0,1.0d0)/

      done = 1
      ifder = 1

      allocate(ephi(-nterms-1:nterms+1))
      allocate(fhs(0:nterms),fhder(0:nterms))
      allocate(ynm(0:nterms,0:nterms))
      allocate(ynmd(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
        if (r.lt.thresh) goto 1000
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms+1
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions:
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r
        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r
        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0
c
c
c
c     get the Hankel functions:
c
        z=zk*r
        call h3dall(nterms,z,rscale,fhs,ifder,fhder)

c     initialize computed values and
c     scale derivatives of Hankel functions so that they are
c     derivatives with respect to r.
c
        do n=0,nterms
          fhder(n)=fhder(n)*zk
        enddo

        do idim=1,nd
          ur(idim) = mpole(idim,0,0)*fhder(0)
          utheta(idim) = 0.0d0
          uphi(idim) = 0.0d0
          pot(idim,itarg)=pot(idim,itarg)+mpole(idim,0,0)*fhs(0)
        enddo

        do n=1,nterms
          ztmp1 = fhs(n)*ynm(n,0)
          ztmp2 = fhder(n)*ynm(n,0)
          ztmp3 = -fhs(n)*ynmd(n,0)*stheta
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+mpole(idim,n,0)*ztmp1
	        ur(idim) = ur(idim) + mpole(idim,n,0)*ztmp2
            utheta(idim) = utheta(idim) + mpole(idim,n,0)*ztmp3
          enddo
          do m=1,n
	        ztmp1=fhs(n)*ynm(n,m)*stheta
            ztmp4 = fhder(n)*ynm(n,m)*stheta
            ztmp5 = -fhs(n)*ynmd(n,m)
            ztmp6 = eye*m*fhs(n)*ynm(n,m)

            do idim=1,nd
              ztmp2 = mpole(idim,n,m)*ephi(m)
	          ztmp3 = mpole(idim,n,-m)*ephi(-m)
	          ztmpsum = ztmp2+ztmp3
	          pot(idim,itarg)=pot(idim,itarg)+ztmp1*ztmpsum
              ur(idim) = ur(idim) + ztmp4*ztmpsum
	          utheta(idim) = utheta(idim) + ztmp5*ztmpsum
	          ztmpsum = ztmp2 - ztmp3
	          uphi(idim) = uphi(idim) + ztmp6*ztmpsum
            enddo
          enddo
        enddo
        do idim=1,nd
          grad(idim,1,itarg) = grad(idim,1,itarg) + ur(idim)*rx +
     1               utheta(idim)*thetax + uphi(idim)*phix
          grad(idim,2,itarg) = grad(idim,2,itarg) + ur(idim)*ry +
     1               utheta(idim)*thetay + uphi(idim)*phiy
          grad(idim,3,itarg) = grad(idim,3,itarg) + ur(idim)*rz +
     1               utheta(idim)*thetaz + uphi(idim)*phiz
        enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dformmpc(nd,zk,rscale,sources,charge,
     1            ns,center,nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Adds to multipole (h) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(ns)      : charge strengths
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the h-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 charge(nd,ns)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:)
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      complex *16, allocatable :: fjs(:),fjder(:),ephi(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder,idim

      ifder=0
      allocate(fjs(0:nterms),fjder(0:nterms),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)

c
c     get Bessel functions
c
        z=zk*r
        call besseljs3d(nterms,z,rscale,fjs,ifder,fjder)
c
c
c     multiply all jn by charge strength and (i*k).
c
        do n = 0,nterms
          fjs(n) = fjs(n)*zkeye
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        e^( i k r}/r =
c         (ik) \sum_n \sum_m  j_n(k|S|) Ylm*(S) h_n(k|T|)Ylm(T)
c
c     so contribution is j_n(k|S|) times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c     The factor (i*k) is taken care of already above
c
        do idim=1,nd
          mpole(idim,0,0)= mpole(idim,0,0) + fjs(0)*charge(idim,isrc)
        enddo
        do n=1,nterms
          ztmp = ynm(n,0)*fjs(n)
          do idim=1,nd
            mpole(idim,n,0)= mpole(idim,n,0) + ztmp*charge(idim,isrc)
          enddo
          do m=1,n
            ztmp=ynm(n,m)*fjs(n)
            do idim=1,nd
              mpole(idim,n,m)= mpole(idim,n,m) +
     1           ztmp*ephi(-m)*charge(idim,isrc)
              mpole(idim,n,-m)= mpole(idim,n,-m) +
     1           ztmp*ephi(m)*charge(idim,isrc)
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dformmpd(nd,zk,rscale,sources,
     1            dipvec,ns,center,nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Adds to multipole (h) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     dipvec(3,ns)    : dipole orientation vectors
C     ns              : number of sources
C     center(3)       : expansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the h-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 dipvec(nd,3,ns)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16, allocatable :: ephi(:),fjs(:),fjder(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye,ztmp1
      complex *16 fjsuse
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      real *8 rx,thetax,phix,ry,thetay,phiy,rz,thetaz,phiz
      complex *16 ux,uy,uz,ur,utheta,uphi,zzz
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder,idim

      ifder=1

      allocate(fjs(0:nterms+1),fjder(0:nterms+1),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms),ynmd(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c     In thetax, thetaty, phix, phiy we leave out the 1/r factors in the
c     change of variables to avoid blow-up at the origin.
c     For the n=0 mode, it is not relevant. For n>0 modes,
c     we use the recurrence relation
c
c     (2n+1)fjs_n(kr)/(kr) = fjs(n+1)*rscale + fjs(n-1)/rscale
c
c     to avoid division by r. The variable fjsuse is set to fjs(n)/r:
c
c           fjsuse = fjs(n+1)*rscale + fjs(n-1)/rscale
c	    fjsuse = wavek*fjsuse/(2*n+1.0d0)
c

        rx = stheta*cphi
        thetax = ctheta*cphi
        phix = -sphi

        ry = stheta*sphi
        thetay = ctheta*sphi
        phiy = cphi

        rz = ctheta
        thetaz = -stheta
        phiz = 0.0d0

        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     get Bessel functions:
c
        z=zk*r
        call besseljs3d(nterms+1,z,rscale,fjs,ifder,fjder)
c
c
c     multiply all jn by  (i*k).
c
        do n = 0,nterms
          fjs(n) = fjs(n)*zkeye
          fjder(n) = fjder(n)*zkeye*zk
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        e^( i k r}/r =
c         (ik) \sum_n \sum_m  j_n(k|S|) Ylm*(S) h_n(k|T|)Ylm(T)
c
c     so contribution is j_n(k|S|) times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c     The factor (i*k) is taken care of already above
c

        ur = ynm(0,0)*fjder(0)
        do idim=1,nd
          zzz = ur*(dipvec(idim,1,isrc)*rx + dipvec(idim,2,isrc)*ry +
     1          dipvec(idim,3,isrc)*rz)
          mpole(idim,0,0)= mpole(idim,0,0)+ zzz
        enddo
        do n=1,nterms
          fjsuse = fjs(n+1)*rscale + fjs(n-1)/rscale
          fjsuse = fjsuse*zk/(2*n+1.0d0)
          ur = ynm(n,0)*fjder(n)
          utheta = -fjsuse*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1               dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + zzz
          enddo
          do m=1,n
            ur = fjder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fjsuse*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fjsuse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              mpole(idim,n, m)= mpole(idim,n, m) + zzz
            enddo

            ur = fjder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fjsuse*ynmd(n,m)
            uphi = eye*m*ephi(m)*fjsuse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux+dipvec(idim,2,isrc)*uy +
     1           dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m) +
     1           zzz
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
c
c
c
c
C***********************************************************************
      subroutine h3dformmpcd(nd,zk,rscale,sources,charge,
     1            dipvec,ns,center,nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Adds to multipole (h) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(ns)      : charge strengths
C     dipvec(3,ns)    : dipole orientation vectors
C     ns              : number of sources
C     center(3)       : expansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the h-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 charge(nd,ns)
      complex *16 dipvec(nd,3,ns)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16, allocatable :: ephi(:),fjs(:),fjder(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye,ztmp1
      complex *16 fjsuse
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      real *8 rx,thetax,phix,ry,thetay,phiy,rz,thetaz,phiz
      complex *16 ux,uy,uz,ur,utheta,uphi,zzz
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder,idim

      ifder=1

      allocate(fjs(0:nterms+1),fjder(0:nterms+1),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms),ynmd(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c     In thetax, thetaty, phix, phiy we leave out the 1/r factors in the
c     change of variables to avoid blow-up at the origin.
c     For the n=0 mode, it is not relevant. For n>0 modes,
c     we use the recurrence relation
c
c     (2n+1)fjs_n(kr)/(kr) = fjs(n+1)*rscale + fjs(n-1)/rscale
c
c     to avoid division by r. The variable fjsuse is set to fjs(n)/r:
c
c           fjsuse = fjs(n+1)*rscale + fjs(n-1)/rscale
c	    fjsuse = wavek*fjsuse/(2*n+1.0d0)
c

        rx = stheta*cphi
        thetax = ctheta*cphi
        phix = -sphi

        ry = stheta*sphi
        thetay = ctheta*sphi
        phiy = cphi

        rz = ctheta
        thetaz = -stheta
        phiz = 0.0d0

        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     get Bessel functions:
c
        z=zk*r
        call besseljs3d(nterms+1,z,rscale,fjs,ifder,fjder)
c
c
c     multiply all jn by  (i*k).
c
        do n = 0,nterms
          fjs(n) = fjs(n)*zkeye
          fjder(n) = fjder(n)*zkeye*zk
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        e^( i k r}/r =
c         (ik) \sum_n \sum_m  j_n(k|S|) Ylm*(S) h_n(k|T|)Ylm(T)
c
c     so contribution is j_n(k|S|) times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c     The factor (i*k) is taken care of already above
c

        ur = ynm(0,0)*fjder(0)
        do idim=1,nd
          zzz = ur*(dipvec(idim,1,isrc)*rx + dipvec(idim,2,isrc)*ry +
     1          dipvec(idim,3,isrc)*rz)
          mpole(idim,0,0)= mpole(idim,0,0) +
     1        fjs(0)*charge(idim,isrc) + zzz
        enddo
        do n=1,nterms
          fjsuse = fjs(n+1)*rscale + fjs(n-1)/rscale
          fjsuse = fjsuse*zk/(2*n+1.0d0)
          ur = ynm(n,0)*fjder(n)
          utheta = -fjsuse*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          ztmp = ynm(n,0)*fjs(n)
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1               dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + ztmp*charge(idim,isrc)+
     1                    zzz
          enddo
          do m=1,n
            ztmp=ynm(n,m)*stheta*fjs(n)
            ztmp1 = ztmp*ephi(-m)
            ur = fjder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fjsuse*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fjsuse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              mpole(idim,n, m)= mpole(idim,n, m) +
     1        ztmp1*charge(idim,isrc) + zzz
            enddo

            ztmp1=ztmp*ephi(m)
            ur = fjder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fjsuse*ynmd(n,m)
            uphi = eye*m*ephi(m)*fjsuse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux+dipvec(idim,2,isrc)*uy +
     1           dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m) +
     1           ztmp1*charge(idim,isrc) + zzz
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine h3dtaevalp(nd,zk,rscale,center,locexp,nterms,ztarg,
     1            ntarg,pot,wlege,nlege)
c**********************************************************************
c
c     This subroutine evaluates the potential
c     of an incoming partial wave expansion and adds to existing
c     quantities.
c
c     pot = pot + sum sum  locexp(n,m) j_n(k r) Y_nm(theta,phi)
c                  n   m
c
c      If r < thresh
c          then the subroutine does not update the potential
c          (recommended value = boxsize(0)*machine precision
c            where boxsize(0) is the size of the computational domain)
c
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of local expansions
c     zk     :    Helmholtz parameter
c     rscale :    scaling parameter
c     center :    expansion center
c     lcoexp :    local expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target locations
c     ntarg  :    number of targets
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :    updated potential at ztarg
c
c-----------------------------------------------------------------------
      implicit none
c
cc      calling sequence variables
c
      integer ntarg,nterms,nlege,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      complex *16 zk,pot(nd,ntarg)
      complex *16 locexp(nd,0:nterms,-nterms:nterms)
      real *8 wlege(*)

c
cc      temporary variables
c
      complex *16, allocatable :: ephi(:),fjs(:)
      real *8, allocatable :: ynm(:,:)
      real *8 zdiff(3),done
      real *8 ctheta,stheta,r,theta,phi,cphi,sphi
      complex *16 ephi1,ur,utheta,uphi
      complex *16 eye
      complex *16 ztmp1,ztmp2,ztmp3,ztmpsum,z
      complex *16 fjder
      integer itarg,i,m,n,ifder,idim
      data eye/(0.0d0,1.0d0)/

      done = 1
      ifder = 0

      allocate(ephi(-nterms-1:nterms+1))
      allocate(fjs(0:nterms))
      allocate(ynm(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta= dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms+1
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions:
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
c
c
c     get the Bessel functions:
c
        z=zk*r
        call besseljs3d(nterms,z,rscale,fjs,ifder,fjder)

        do idim=1,nd
          pot(idim,itarg)=pot(idim,itarg)+locexp(idim,0,0)*fjs(0)
        enddo
        do n=1,nterms
          ztmp1 = fjs(n)*ynm(n,0)
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+locexp(idim,n,0)*ztmp1
          enddo
          do m=1,n
	        ztmp1=fjs(n)*ynm(n,m)
            do idim=1,nd
              ztmpsum = locexp(idim,n,m)*ephi(m) +
     1            locexp(idim,n,-m)*ephi(-m)
              pot(idim,itarg)=pot(idim,itarg)+ztmp1*ztmpsum
            enddo
          enddo
        enddo
 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine h3dtaevalg(nd,zk,rscale,center,locexp,nterms,
     1            ztarg,ntarg,pot,grad,wlege,nlege)
c**********************************************************************
c
c     This subroutine evaluates the potential, and gradient
c     of an incoming partial wave expansion and adds to existing
c     quantities.
c
c     pot = pot + sum sum  locexp(n,m) j_n(k r) Y_nm(theta,phi)
c                  n   m
c
c     grad = grad + Gradient( sum sum  locexp(n,m) j_n(k r) Y_nm(theta,phi))
c                              n   m
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of local expansions
c     zk     :    Helmholtz parameter
c     rscale :    scaling parameter
c     center :    expansion center
c     locexp :    multipole expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target locations
c     ntarg  :    number of targets
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :    updated potential at ztarg
c     grad    :   updated gradient at ztarg
c
c-----------------------------------------------------------------------
      implicit none
c
cc      calling sequence variables
c
      integer ntarg,nterms,nlege,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      complex *16 zk,pot(nd,ntarg),grad(nd,3,ntarg)
      complex *16 locexp(nd,0:nterms,-nterms:nterms)
      real *8 wlege(*),thresh

c
cc      temporary variables
c
      complex *16, allocatable :: ephi(:),fjs(:),fjder(:)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      real *8 zdiff(3),done
      real *8 r, theta,phi,ctheta,stheta,cphi,sphi
      real *8 rx,ry,rz
      real *8 phix,phiy,phiz
      real *8 thetax,thetay,thetaz,dtmp
      complex *16 ephi1,ur(nd),utheta(nd),uphi(nd)
      complex *16 fjsuse
      complex *16 eye
      complex *16 ztmp1,ztmp2,ztmp3,ztmpsum,z
      complex *16 ztmp4,ztmp5,ztmp6
      integer itarg,i,m,n,ifder,idim
      data eye/(0.0d0,1.0d0)/

      done = 1
      ifder = 1

      allocate(ephi(-nterms-1:nterms+1))
      allocate(fjs(0:nterms+1),fjder(0:nterms+1))
      allocate(ynm(0:nterms,0:nterms))
      allocate(ynmd(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms+1
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions:
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
        rx = stheta*cphi
        thetax = ctheta*cphi
        phix = -sphi
        ry = stheta*sphi
        thetay = ctheta*sphi
        phiy = cphi
        rz = ctheta
        thetaz = -stheta
        phiz = 0.0d0
c
c
c
c     get the Bessel functions:
c
        z=zk*r
        call besseljs3d(nterms+1,z,rscale,fjs,ifder,fjder)

c     initialize computed values and
c     scale derivatives of Hankel functions so that they are
c     derivatives with respect to r.
c
        do n=0,nterms
          fjder(n)=fjder(n)*zk
        enddo

        do idim=1,nd
          ur(idim) = locexp(idim,0,0)*fjder(0)
          utheta(idim) = 0.0d0
          uphi(idim) = 0.0d0
          pot(idim,itarg)=pot(idim,itarg)+locexp(idim,0,0)*fjs(0)
        enddo

        do n=1,nterms
          fjsuse = fjs(n+1)*rscale + fjs(n-1)/rscale
          fjsuse = fjsuse*zk/(2*n+1.0d0)
          ztmp1 = fjs(n)*ynm(n,0)
          ztmp2 = fjder(n)*ynm(n,0)
          ztmp3 = -fjsuse*ynmd(n,0)*stheta
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+locexp(idim,n,0)*ztmp1
	        ur(idim) = ur(idim) + locexp(idim,n,0)*ztmp2
            utheta(idim) = utheta(idim) + locexp(idim,n,0)*ztmp3
          enddo
          do m=1,n
	        ztmp1=fjs(n)*ynm(n,m)*stheta
            ztmp4 = fjder(n)*ynm(n,m)*stheta
            ztmp5 = -fjsuse*ynmd(n,m)
            ztmp6 = eye*m*fjsuse*ynm(n,m)

            do idim=1,nd
              ztmp2 = locexp(idim,n,m)*ephi(m)
	          ztmp3 = locexp(idim,n,-m)*ephi(-m)
	          ztmpsum = ztmp2+ztmp3
              pot(idim,itarg)=pot(idim,itarg) + ztmp1*ztmpsum
	          ur(idim) = ur(idim) + ztmp4*ztmpsum
	          utheta(idim) = utheta(idim) + ztmp5*ztmpsum
	          ztmpsum = ztmp2 - ztmp3
	          uphi(idim) = uphi(idim) + ztmp6*ztmpsum
            enddo
          enddo
        enddo
        do idim=1,nd
          grad(idim,1,itarg) = grad(idim,1,itarg)+ur(idim)*rx +
     1          utheta(idim)*thetax + uphi(idim)*phix
          grad(idim,2,itarg) = grad(idim,2,itarg)+ur(idim)*ry +
     1          utheta(idim)*thetay + uphi(idim)*phiy
          grad(idim,3,itarg) = grad(idim,3,itarg)+ur(idim)*rz +
     1          utheta(idim)*thetaz + uphi(idim)*phiz

        enddo
      enddo

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dformtac(nd,zk,rscale,sources,charge,
     1            ns,center,nterms,locexp,wlege,nlege)
C***********************************************************************
C
C     Adds to local (j) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of local expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(ns)      : charge strengths
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     locexp          : coeffs of the j-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 charge(nd,ns)
      complex *16 locexp(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:)
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      complex *16, allocatable :: fhs(:),fhder(:),ephi(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder,idim

      ifder=0
      allocate(fhs(0:nterms),fhder(0:nterms),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)

c
c     get Hankel functions
c
        z=zk*r
        call h3dall(nterms,z,rscale,fhs,ifder,fhder)
c
c
c     multiply all hn by charge strength and (i*k).
c
        do n = 0,nterms
          fhs(n) = fhs(n)*zkeye
        enddo
c
c
c     Compute contribution to locexp coefficients.
c
        do idim=1,nd
          locexp(idim,0,0)= locexp(idim,0,0) + fhs(0)*charge(idim,isrc)
        enddo
        do n=1,nterms
          ztmp = ynm(n,0)*fhs(n)
          do idim=1,nd
            locexp(idim,n,0)= locexp(idim,n,0) + ztmp*charge(idim,isrc)
          enddo
          do m=1,n
            ztmp=ynm(n,m)*fhs(n)
            do idim=1,nd
              locexp(idim,n, m)= locexp(idim,n, m) +
     1            ztmp*ephi(-m)*charge(idim,isrc)
              locexp(idim,n,-m)= locexp(idim,n,-m) +
     1           ztmp*ephi(m)*charge(idim,isrc)
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dformtad(nd,zk,rscale,sources,
     1            dipvec,ns,center,nterms,locexp,wlege,nlege)
C***********************************************************************
C
C     Adds to multipole (h) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of local expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     dipvec(3,ns)    : dipole orientation vectors
C     ns              : number of sources
C     center(3)       : expansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     locexp          : coeffs of the h-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 dipvec(nd,3,ns)
      complex *16 locexp(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16, allocatable :: ephi(:),fhs(:),fhder(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye,ztmp1
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      real *8 rx,thetax,phix,ry,thetay,phiy,rz,thetaz,phiz
      complex *16 ux,uy,uz,ur,utheta,uphi,zzz
      integer idim
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder

      ifder=1

      allocate(fhs(0:nterms),fhder(0:nterms),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms),ynmd(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c

        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r

        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r

        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0

        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     get Hankel functions:
c
        z=zk*r
        call h3dall(nterms,z,rscale,fhs,ifder,fhder)
c
c
c     multiply all hn by  (i*k).
c
        do n = 0,nterms
          fhs(n) = fhs(n)*zkeye
          fhder(n) = fhder(n)*zkeye*zk
        enddo
c
c
c     Compute contribution to locexp coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        e^( i k r}/r =
c         (ik) \sum_n \sum_m  j_n(k|T|) Ylm*(T) h_n(k|S|)Ylm(S)
c
c     so contribution is j_n(k|S|) times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c     The factor (i*k) is taken care of already above
c

        ur = ynm(0,0)*fhder(0)
        do idim=1,nd
          zzz = ur*(dipvec(idim,1,isrc)*rx + dipvec(idim,2,isrc)*ry +
     1          dipvec(idim,3,isrc)*rz)
          locexp(idim,0,0)= locexp(idim,0,0)+zzz
        enddo
        do n=1,nterms
          ur = ynm(n,0)*fhder(n)
          utheta = -fhs(n)*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz

          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
            locexp(idim,n,0)= locexp(idim,n,0)+zzz
          enddo
          do m=1,n
            ur = fhder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fhs(n)*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fhs(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              locexp(idim,n,m)= locexp(idim,n,m)+zzz
            enddo

            ur = fhder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fhs(n)*ynmd(n,m)
            uphi = eye*m*ephi(m)*fhs(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              locexp(idim,n,-m)= locexp(idim,n,-m)+
     1            zzz
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dformtacd(nd,zk,rscale,sources,charge,
     1            dipvec,ns,center,nterms,locexp,wlege,nlege)
C***********************************************************************
C
C     Adds to multipole (h) expansion about CENTER due to NS sources
C     located at SOURCES(3,*)
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of local expansions
C     zk              : Helmholtz parameter
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(ns)      : charge strengths
C     dipvec(3,ns)    : dipole orientation vectors
C     ns              : number of sources
C     center(3)       : expansion center
C     nterms          : order of multipole expansion
c     wlege           : precomputed array of scaling coeffs for Pnm
c     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     locexp          : coeffs of the h-expansion
c
c-----------------------------------------------------------------------
      implicit none
      integer ns,nterms,nlege,nd
      complex *16 zk
      real *8 rscale,sources(3,ns),center(3),wlege(*)
      complex *16 charge(nd,ns)
      complex *16 dipvec(nd,3,ns)
      complex *16 locexp(nd,0:nterms,-nterms:nterms)
c
cc      temporary variables
c
c
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16, allocatable :: ephi(:),fhs(:),fhder(:)
      complex *16 ephi1,ephi1inv
      complex *16 z,ztmp,zkeye,eye,ztmp1
      real *8 r,theta,phi
      real *8 ctheta,stheta,cphi,sphi
      real *8 rx,thetax,phix,ry,thetay,phiy,rz,thetaz,phiz
      complex *16 ux,uy,uz,ur,utheta,uphi,zzz
      integer idim
      data eye/(0.0d0,1.0d0)/

      integer isrc,i,m,n,ifder

      ifder=1

      allocate(fhs(0:nterms),fhder(0:nterms),ephi(-nterms:nterms))
      allocate(ynm(0:nterms,0:nterms),ynmd(0:nterms,0:nterms))

      zkeye = eye*zk

      do isrc=1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)

        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c

        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r

        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r

        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0

        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        do i=2,nterms
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
c
c     get the associated Legendre functions
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
c
c     get Hankel functions:
c
        z=zk*r
        call h3dall(nterms,z,rscale,fhs,ifder,fhder)
c
c
c     multiply all hn by  (i*k).
c
        do n = 0,nterms
          fhs(n) = fhs(n)*zkeye
          fhder(n) = fhder(n)*zkeye*zk
        enddo
c
c
c     Compute contribution to locexp coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        e^( i k r}/r =
c         (ik) \sum_n \sum_m  j_n(k|T|) Ylm*(T) h_n(k|S|)Ylm(S)
c
c     so contribution is j_n(k|S|) times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c     The factor (i*k) is taken care of already above
c

        ur = ynm(0,0)*fhder(0)
        do idim=1,nd
          zzz = ur*(dipvec(idim,1,isrc)*rx + dipvec(idim,2,isrc)*ry +
     1          dipvec(idim,3,isrc)*rz)
          locexp(idim,0,0)= locexp(idim,0,0)+fhs(0)*charge(idim,isrc)+
     1       zzz
        enddo
        do n=1,nterms
          ur = ynm(n,0)*fhder(n)
          utheta = -fhs(n)*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz

          ztmp = fhs(n)*ynm(n,0)
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
            locexp(idim,n,0)= locexp(idim,n,0) +
     1             ztmp*charge(idim,isrc) + zzz
          enddo
          do m=1,n
            ztmp=ynm(n,m)*stheta*fhs(n)
            ztmp1 = ztmp*ephi(-m)

            ur = fhder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fhs(n)*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fhs(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              locexp(idim,n,m)= locexp(idim,n,m) +
     1           ztmp1*charge(idim,isrc) + zzz
            enddo

            ztmp1 = ztmp*ephi(m)
            ur = fhder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fhs(n)*ynmd(n,m)
            uphi = eye*m*ephi(m)*fhs(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1             dipvec(idim,3,isrc)*uz
              locexp(idim,n,-m)= locexp(idim,n,-m) +
     1             ztmp1*charge(idim,isrc) +  zzz
            enddo
          enddo
        enddo
      enddo

      return
      end
c


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Real dilogarithm \f$\mathrm{Li}_2(x)\f$
!> @param x real argument
!> @return \f$\mathrm{Li}_2(x)\f$
!> @author Alexander Voigt
!>
!> Implemented as an economized Pade approximation with a
!> maximum error of 4.16e-18.
!*********************************************************************
      double precision function dli2(x)
      implicit none
      double precision x, y, r, s, z, z2, z4, p, q, l, PI
      parameter (PI = 3.14159265358979324D0)
      double precision cp(8), cq(8)
      data cp / 1.0706105563309304277D+0,
     &         -4.5353562730201404017D+0,
     &          7.4819657596286408905D+0,
     &         -6.0516124315132409155D+0,
     &          2.4733515209909815443D+0,
     &         -4.6937565143754629578D-1,
     &          3.1608910440687221695D-2,
     &         -2.4630612614645039828D-4 /
      data cq / 1.0000000000000000000D+0,
     &         -4.5355682121856044935D+0,
     &          8.1790029773247428573D+0,
     &         -7.4634190853767468810D+0,
     &          3.6245392503925290187D+0,
     &         -8.9936784740041174897D-1,
     &          9.8554565816757007266D-2,
     &         -3.2116618742475189569D-3 /

      ! transform to [0, 1/2)
       if (x .lt. -1) then
          l = log(1 - x)
          y = 1/(1 - x)
          r = -PI**2/6 + l*(0.5D0*l - log(-x))
          s = 1
       elseif (x .eq. -1) then
          dli2 = -PI**2/12
          return
       elseif (x .lt. 0) then
          y = x/(x - 1)
          r = -0.5D0*log(1 - x)**2
          s = -1
       elseif (x .eq. 0) then
          dli2 = 0
          return
       elseif (x .lt. 0.5D0) then
          y = x
          r = 0
          s = 1
       elseif (x .lt. 1) then
          y = 1 - x
          r = PI**2/6 - log(x)*log(1 - x)
          s = -1
       elseif (x .eq. 1) then
          dli2 = PI**2/6
          return
       elseif (x .lt. 2) then
          l = log(x)
          y = 1 - 1/x
          r = PI**2/6 - l*(log(1 - 1/x) + 0.5D0*l)
          s = 1
       else
          y = 1/x
          r = PI**2/3 - 0.5D0*log(x)**2
          s = -1
       endif

      z = y - 0.25D0
      z2 = z*z
      z4 = z2*z2

      p = cp(1) + z * cp(2) + z2 * (cp(3) + z * cp(4)) +
     &    z4 * (cp(5) + z * cp(6) + z2 * (cp(7) + z * cp(8)))
      q = cq(1) + z * cq(2) + z2 * (cq(3) + z * cq(4)) +
     &    z4 * (cq(5) + z * cq(6) + z2 * (cq(7) + z * cq(8)))

      dli2 = r + s*y*p/q

      end

!*********************************************************************
!> @brief Complex dilogarithm \f$\mathrm{Li}_2(z)\f$
!> @param z complex argument
!> @return \f$\mathrm{Li}_2(z)\f$
!> @note Implementation adapted from SPheno by Alexander Voigt
!*********************************************************************
      double complex function cdli2(z)
      implicit none
      double complex z, rest, u, u2, u4, sum, fast_cdlog
      double precision rz, iz, nz, sgn, dli2, PI
      parameter (PI = 3.14159265358979324D0)
      double precision bf(10)
      data bf /- 2.5000000000000000D-01,
     &         + 2.7777777777777778D-02,
     &         - 2.7777777777777778D-04,
     &         + 4.7241118669690098D-06,
     &         - 9.1857730746619636D-08,
     &         + 1.8978869988970999D-09,
     &         - 4.0647616451442255D-11,
     &         + 8.9216910204564526D-13,
     &         - 1.9939295860721076D-14,
     &         + 4.5189800296199182D-16 /

      rz = real(z)
      iz = dimag(z)

      ! special cases
      if (iz .eq. 0) then
         if (rz .le. 1) cdli2 = dcmplx(dli2(rz), 0)
         if (rz .gt. 1) cdli2 = dcmplx(dli2(rz), -PI*log(rz))
         return
      endif

      nz = rz**2 + iz**2

      if (nz .lt. 1.0D-15) then
         cdli2 = z*(1 + 0.25D0*z)
         return
      endif

      ! transformation to |z| < 1, Re(z) <= 0.5
      if (rz .le. 0.5D0) then
         if (nz .gt. 1) then
            u = -fast_cdlog(1 - 1/z)
            rest = -0.5D0*fast_cdlog(-z)**2 - PI**2/6
            sgn = -1
         else ! nz <= 1
            u = -fast_cdlog(1 - z)
            rest = 0
            sgn = 1
         endif
      else ! rz > 0.5D0
         if (nz .le. 2*rz) then
            u = -fast_cdlog(z)
            rest = u*fast_cdlog(1 - z) + PI**2/6
            sgn = -1
         else ! nz > 2*rz
            u = -fast_cdlog(1 - 1/z)
            rest = -0.5D0*fast_cdlog(-z)**2 - PI**2/6
            sgn = -1
         endif
      endif

      u2 = u**2
      u4 = u2**2
      sum =
     &   u +
     &   u2 * (bf(1) +
     &   u  * (bf(2) +
     &   u2 * (
     &       bf(3) +
     &       u2*bf(4) +
     &       u4*(bf(5) + u2*bf(6)) +
     &       u4*u4*(bf(7) + u2*bf(8) + u4*(bf(9) + u2*bf(10)))
     &   )))

      cdli2 = sgn*sum + rest

      end


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c
c  This subroutine is the implementation of Mackowski's three-step
c  method for decomposition of translation matrix into rotational
c  and axial translational parts.
c  The rotation-translation-rotation formulation is described
c  in Mackowski, Proc. R. Soc. Lond. A 433, pp.611-612 (1991).
c  Yu-lin Xu   12/2000
c
      subroutine rtr(anpt,nodrj,nodri,ekt,drot)
      implicit double precision (a-h,o-z)
      include 'gmm01f.par'
      parameter(nmp=np*(np+2))
      double precision drot(*)
      complex*16 anpt(2,*),ant(2,2*np),amt(2,-np:np),a,b,
     +           ekt(*),ek(-np:np),atr(2,np,nmp)
      common/tran/atr
c
      ek(0)=1.d0
      nmax=max(nodrj,nodri)
      do m=1,nmax
         ek(m)=ekt(m)
         ek(-m)=dconjg(ek(m))
      enddo
      irc=0
      do n=1,nodrj
         n1=n*(n+1)
         do m=-n,n
            amt(1,m)=0.d0
            amt(2,m)=0.d0
         enddo
         do k=-n,n
            kn=n1+k
            a=ek(k)*anpt(1,kn)
            b=ek(k)*anpt(2,kn)
            do m=-n,n
               irc=irc+1
               amt(1,m)=amt(1,m)+a*drot(irc)
               amt(2,m)=amt(2,m)+b*drot(irc)
            enddo
         enddo
         do m=-n,n
            imn=n1+m
            anpt(1,imn)=amt(1,m)
            anpt(2,imn)=amt(2,m)
         enddo
      enddo
      mmax=min(nodrj,nodri)
      do m=-mmax,mmax
         n1=max(1,iabs(m))
         do n=n1,nodrj
            imn=n*(n+1)+m
            do ip=1,2
               ant(ip,n)=anpt(ip,imn)
            enddo
         enddo
         do n=n1,nodri
            imn=n*(n+1)+m
            a=0.d0
            b=0.d0
            do l=n1,nodrj
               ml=l*(l+1)+m
               a=a+atr(1,n,ml)*ant(1,l)
     1            +atr(2,n,ml)*ant(2,l)
               b=b+atr(1,n,ml)*ant(2,l)
     1            +atr(2,n,ml)*ant(1,l)
            enddo
            anpt(1,imn) = a
            anpt(2,imn) = b
         enddo
      enddo
      in=1
      irc=0
      do n=1,nodri
         in=-in
         n1=n*(n+1)
         do m=-n,n
            amt(1,m)=0.d0
            amt(2,m)=0.d0
         enddo
         sik=-in
         do k=-n,n
        sik=-sik
        kn=n1+k
        a=sik*anpt(1,kn)
            b=sik*anpt(2,kn)
            do m=-n,n
               irc=irc+1
               amt(1,m)=amt(1,m)+a*drot(irc)
               amt(2,m)=amt(2,m)+b*drot(irc)
            enddo
         enddo
         sik=-in
         do m=-n,n
            sik=-sik
            imn=n1+m
            anpt(1,imn)=amt(1,m)*ek(-m)*sik
            anpt(2,imn)=amt(2,m)*ek(-m)*sik
         enddo
      enddo
      return
      end


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!              Main authors: Vitaliy Ogarko, Roland Martin,
!                   Jeremie Giraud, Dimitri Komatitsch.
!
! (c) CNRS, France, and University of Western Australia. January 2018
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!==============================================================================================================
! Contains various helper functions used in the code, which are not dependent on other modules,
! do not logically belong to a particular module, and can be easily moved here.
!
! Vitaliy Ogarko, UWA, CET, Australia, 2015.
!==============================================================================================================
module utils

  use global_typedefs, only: CUSTOM_REAL, NORM_L2

  implicit none

  private

  public :: compute_snrm
  public :: enforce_pb
  public :: der
  public :: avg2
  public :: avg4
  public :: getstep

contains

!==============================================================================================================
!! DK DK and DG DG: this is *not* BLAS1 SNRM2() because it has no square root at the end
!! DK DK and DG DG: and there is also a if statement to choose between L1 and L2 norm

!! DK DK and DG DG: it seems to us that the L1 norm does not work anyway because in the calling program
!! DK DK and DG DG: we then *always* take the square root of the result, which makes no sense for L1.

!! DK DK and DG DG: also, the mpi_reduce which is called in the main program after calls to this routine
!! DK DK and DG DG: always uses MPI_SUM and not MPI_MAX, thus again it would not work for L1.

!! DK DK and DG DG: thus, there is room for improvement here because if we only consider L2 then we can probably
!! DK DK and DG DG: switch to a BLAS1 call (?)
!==============================================================================================================
subroutine compute_snrm(sx,itypenorm,nr,ntheta,nz,i_begin,j_begin,k_begin,i_end,j_end,k_end,snrm)

  integer, intent(in) :: nr,ntheta,nz
  real(kind=CUSTOM_REAL), intent(in) :: sx(0:nr+1,0:ntheta+1,0:nz+1)
  !! select the norm to use depending on this parameter "itypenorm"
  integer, intent(in) :: itypenorm
  integer, intent(in) :: i_begin,j_begin,k_begin,i_end,j_end,k_end
  real(kind=CUSTOM_REAL), intent(out) :: snrm

  integer :: i,j,k,isamax,jsamax,ksamax

  if (itypenorm == NORM_L2) then
    !! L2 norm here, without square root calculation at the end
    snrm=0._CUSTOM_REAL
    do k=k_begin,k_end
      do j=j_begin,j_end
        do i=i_begin,i_end
          snrm=snrm+sx(i,j,k)**2
        enddo
      enddo
    enddo

  else
    ! DK DK and DG DG: L1 norm (max norm) here
    isamax=1
    jsamax=1
    ksamax=1
    do k=k_begin,k_end
      do j=j_begin,j_end
        do i=i_begin,i_end
          if(abs(sx(i,j,k))>abs(sx(isamax,jsamax,ksamax)))then
            isamax=i
            jsamax=j
            ksamax=k
          endif
        enddo
      enddo
    enddo
    snrm=abs(sx(isamax,jsamax,ksamax))

  endif

end subroutine compute_snrm

!==========================================================================
! Enforce periodic boundary conditions on x (in cylindrical coordinates).
!==========================================================================
pure subroutine enforce_pb(nr, ntheta, nz, x)
  integer, intent(in) :: nr, ntheta, nz
  real(kind=CUSTOM_REAL), intent(inout) :: x(0:nr+1, 0:ntheta+1, 0:nz+1)

  integer :: i, k

  do k = 0, nz + 1
    do i = 0, nr + 1
      x(i, 0, k) = x(i, ntheta, k)
      x(i, ntheta + 1, k) = x(i, 1, k)
    enddo
  enddo
end subroutine enforce_pb

!====================================================================
! Four-points stencil first derivative.
!====================================================================
function der(f0,f1,f2,f3,h)
  real(kind=CUSTOM_REAL), intent(in) :: f0, f1, f2, f3
  real(kind=CUSTOM_REAL), intent(in) :: h
  real(kind=CUSTOM_REAL) :: der

  ! 2nd order interpolation.
  der = (2._CUSTOM_REAL*f3 - 9._CUSTOM_REAL*f2 + 18._CUSTOM_REAL*f1 - &
         11._CUSTOM_REAL*f0) / (6._CUSTOM_REAL*h)

  ! 1st order interpolation.
  !der = (f1 - f0) / h

  return
end function der

!====================================================================
! Physically accurate average of 2 values.
!====================================================================
pure function avg2(a1, a2) result(res)
  real(kind=CUSTOM_REAL), intent(in) :: a1, a2
  real(kind=CUSTOM_REAL) :: res

  ! Option 1: linear.
!  res = 0.5_CUSTOM_REAL*(a1+a2)

  ! Option 2: quadratic - more accurate.
  if (a1 + a2 == 0._CUSTOM_REAL) then
    res = 0._CUSTOM_REAL
  else
    res = 2._CUSTOM_REAL * (a1 * a2) / (a1 + a2)
  endif
end function avg2

!========================================================================
! Physically accurate average of 4 values.
!========================================================================
pure function avg4(a1, a2, a3, a4) result(res)
  real(kind=CUSTOM_REAL), intent(in) :: a1, a2, a3, a4
  real(kind=CUSTOM_REAL) :: denom
  real(kind=CUSTOM_REAL) :: res

  ! Option 1: linear.
!  res = 0.25_CUSTOM_REAL * (a1 + a2 + a3 + a4)

  ! Option 2: quadratic - more accurate.
  !denom = a2*a3*a4 + a1*a3*a4 + a1*a2*a4 + a1*a2*a3
  denom = a3 * a4 * (a1 + a2) + a1 * a2 * (a3 + a4)
  if (denom == 0._CUSTOM_REAL) then
    res = 0._CUSTOM_REAL
  else
    res = 4._CUSTOM_REAL * (a1 * a2 * a3 * a4) / denom
  endif
end function avg4

!=================================================================================
! Trapezoidal integration rule (with varying step).
! Return integration step.
! di -- change in index i of data array a, di=1 for all except radius, where di=2.
!=================================================================================
function getstep(i,di,istart,iend,n,a)
  integer, intent(in) :: i,di,istart,iend,n
  real(kind=CUSTOM_REAL), intent(in) :: a(0:n)
  real(kind=CUSTOM_REAL) :: getstep

  ! Sanity check.
  if (i < 0 .or. i > n) then
    print *, 'Error in getstep(). Exiting.'
    stop
  endif

  if (i == istart) then
    getstep = 0.5_CUSTOM_REAL*abs(a(i+di) - a(i))
  else if (i == iend) then
    getstep = 0.5_CUSTOM_REAL*abs(a(i) - a(i-di))
  else
    getstep = 0.5_CUSTOM_REAL*abs(a(i+di) - a(i-di))
  endif

  return
end function getstep

end module utils


!
!   rtbis.f90
!
!
!   Created by Kurt Mitman on 19/03/15.
!   Copyright 2015 __MyCompanyName__. All rights reserved.
!
SUBROUTINE rtbis(func,x1,x2,xacc,ftol,xout)
IMPLICIT NONE
DOUBLE PRECISION, INTENT(IN) :: x1,x2,xacc,ftol
DOUBLE PRECISION, INTENT(OUT) :: xout
DOUBLE PRECISION :: lrtbis
INTEGER, PARAMETER :: MAXIT=80
INTEGER :: j
DOUBLE PRECISION :: dx,f,fmid,xmid
DOUBLE PRECISION, EXTERNAL       :: func
fmid=func(x2)
f=func(x1)
if (f*fmid >= 0.0) then
if (abs(f)<ftol .or. abs(fmid)<ftol) then
if (abs(f)<ftol .and. abs(fmid)<ftol) write(*,*) 'rtbis: both initial points have abs <ftol'
if(abs(f)<=abs(fmid)) xout = x1
if(abs(fmid)<abs(f)) xout = x2
f = func(xout)  !so that last one called is correct to set globals.
return
end if
write(*,*)'rtbis: root must be bracketed'
return
end if
if (f < 0.0) then
lrtbis=x1
dx=x2-x1
else
lrtbis=x2
dx=x1-x2
end if
do j=1,MAXIT
dx=dx*0.5_8
xmid=lrtbis+dx
fmid=func(xmid)
if (fmid <= 0.0) lrtbis=xmid
if (abs(dx) < xacc .or. abs(fmid) < ftol) then
xout = lrtbis
RETURN
end if
end do
write(*,*)'rtbis: too many bisections'

END SUBROUTINE rtbis


! $UWHPSC/codes/mpi/pisum1.f90

! Computes pi using MPI.
! Compare to $UWHPSC/codes/openmp/pisum2.f90

program pisum1
    use mpi
    implicit none
    integer :: ierr, numprocs, proc_num, points_per_proc, n, &
               i, istart, iend
    real (kind=8) :: x, dx, pisum, pisum_proc, pi

    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, numprocs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, proc_num, ierr)

    ! Ask the user for the number of points
    if (proc_num == 0) then
        print *, "Using ",numprocs," processors"
        print *, "Input n ... "
        read *, n
    end if

    ! Broadcast to all procs; everybody gets the value of n from proc 0
    call mpi_bcast(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

    dx = 1.d0/n

    ! Determine how many points to handle with each proc
    points_per_proc = (n + numprocs - 1)/numprocs
    if (proc_num == 0) then   ! Only one proc should print to avoid clutter
        print *, "points_per_proc = ", points_per_proc
    end if

    ! Determine start and end index for this proc's points
    istart = proc_num * points_per_proc + 1
    iend = min((proc_num + 1)*points_per_proc, n)

    ! Diagnostic: tell the user which points will be handled by which proc
    print '("Process ",i2," will take i = ",i6," through i = ",i6)', &
          proc_num, istart, iend

    pisum_proc = 0.d0
    do i=istart,iend
        x = (i-0.5d0)*dx
        pisum_proc = pisum_proc + 1.d0 / (1.d0 + x**2)
    enddo

    call MPI_REDUCE(pisum_proc,pisum,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
                        MPI_COMM_WORLD,ierr)

    if (proc_num == 0) then
        pi = 4.d0 * dx * pisum
        print *, "The approximation to pi is ",pi
        endif

    call mpi_finalize(ierr)

end program pisum1


! $UWHPSC/codes/adaptive_quadrature/openmp1/testquad.f90

! Test the quadrature module.

program main

    use omp_lib
    use adapquad_mod    ! defines adapquad
    use functions_mod   ! defines g and gint, and gcounter
    use evalfunc_mod    ! defines evalfunc

    implicit none
    real(kind=8) :: a, b, int_approx, int_true, tol, errest, error, &
                    xmid,intest1,intest2,errest1,errest2,tol2
    integer :: thread_num

    ! Specify number of threads to use:
    !   (only 1 or 2 since interval split in half)
    nthreads = 1
    !$ nthreads = 2
    !$ call omp_set_num_threads(nthreads)
    !$ print *, "Compiled with OpenMP"
    print "('Using ',i3,' threads')", nthreads

    ! open file for writing quadrature points used:
    open(unit=7,file="fquadpts.txt")

    ! open file for writing intervals and levels:
    open(unit=8,file="intervals.txt")

    print *, "Tolerance? "
    read *, tol
    a = -2.d0
    b = 4.d0

    ! true solution:
    int_true = gint(b) - gint(a)

    ! gcounter, a module variable in functions_mod,
    ! keeps track of how many times g is evaluated.
    gcounter = 0

    xmid = 0.5d0*(a+b)
    tol2 = tol / 2.d0

    !$omp parallel sections
    !$omp section
        call adapquad(g,a,xmid,tol2,intest1,errest1)
    !$omp section
        call adapquad(g,xmid,b,tol2,intest2,errest2)
    !$omp end parallel sections

    int_approx = intest1 + intest2
    errest = errest1 + errest2

    error = int_approx - int_true
    print 61, tol
    print 62, int_approx, int_true, error, errest
61  format(/,"Adaptive quadrature:    tol = ",e13.6)
62  format("   approx = ",e20.13, /, &
           "   true =   ",e20.13, /, &
           "   error =  ",e10.3, /, &
           "   errest = ",e10.3)

    print 63, gcounter
63  format("   g was evaluated ",i9," times")

    open(unit=9,file="info.txt")
    write(9,901) tol,gcounter
901 format(e14.5, i8)

    ! evaluate and print g for plotting purposes:
    call evalfunc(g, a, b)

end program main


program fourier_test

  use, intrinsic :: iso_c_binding

  implicit none
  include 'fftw3.f03'

  type(C_PTR) :: plan
  complex(C_DOUBLE_COMPLEX), dimension(1:8) :: in, out

  plan = fftw_plan_dft_1d(8, in, out, FFTW_FORWARD, FFTW_ESTIMATE)

  in(1) = (0.0, 0.d0)
  in(2) = (0.0, 1.d0)
  in(3) = (0.0, 0.d0)
  in(4) = (0.d0, 0.d0)

  write(unit=*, fmt=*) 'in', in
  write(unit=*, fmt=*) 'out', out
  write(unit=*, fmt=*)

  call fftw_execute_dft(plan, in, out)

  write(unit=*, fmt=*) 'in', in
  write(unit=*, fmt=*) 'out', out
  write(unit=*, fmt=*)

  call fftw_destroy_plan(plan)

  plan = fftw_plan_dft_1d(8, in, out, FFTW_BACKWARD, FFTW_ESTIMATE) ! FFTW_MEASURE

  call fftw_execute_dft(plan, out, in)

  write(unit=*, fmt=*) 'in', in
  write(unit=*, fmt=*) 'out', out
  write(unit=*, fmt=*)

  call fftw_destroy_plan(plan)

end program fourier_test


module totaleventrate
    use quadrature
    use constants
    use eventrate
    use settings
    use main

    contains
    subroutine totaler()

        implicit none
        real(kind=8) :: q_start, q_stop, error, relerror, result, abserror
        real(kind=8) :: mtarget
        integer :: ind

        mtarget = nuc_target%mass

        print*,"Using adaptive numerical integration to determine &
             & total integrated event rate."
        call get_q_limits(mtarget, q_start, q_stop, relerror)

        print*,"Computing integral..."
        abserror=fspectra(q_stop) ! This line prevents a segfault... idk why
        relerror = quadrature_relerr

        call gaus8_threadsafe(fspectra,  q_start, q_stop, relerror, result, ind, 1)

        print*,"Error estimate:"
        print*,error

        print*,"Total integrated events:"
        print*,result

    end subroutine totaler

    function fspectra(q)
        ! The purpose of this function is to create a callable func for the
        ! adaptive integral routine. Other functions in this program use
        ! (the good practice of) explicit data dependency. An exception
        ! was made for this fuction for compatibility with the adaptive
        ! integration routine used to integrate the event rate spectra.

        implicit none
        real(kind=8), intent(in) :: q
        real(kind=8) :: fspectra

        fspectra = q * dEventRate(q) /(mn*nuc_target%mass)

    end function

    subroutine get_q_limits(mtarget,q_start, q_stop, error)

        implicit none
        real(kind=8) :: mtarget, E_start, E_stop, error
        real(kind=8) :: q_start, q_stop

        ! Get recoil energy grid from user or from file
        if (usemomentum) then
            print*,'What are the limits of integration for transfer momenta?'
            print*,'Enter starting momentum, stopping momentum, relative error:'
            read*,q_start, q_stop, error
        else
            print*,'What are the limits of integration for recoil energies in kev?'
            print*,'Enter starting energy, stoping energy, relative error:'
            read*,E_start, E_stop, error
        end if

        E_start = E_start + 1e-12
        q_start = q_start + 1e-12

        if (.not.usemomentum) then
            q_start = sqrt(2d0*mtarget*mN*E_start*kev)
            q_stop =sqrt(2d0*mtarget*mN*E_stop*kev)
        end if

        print*,"q min  (gev/c)",q_start
        print*,"q max  (gev/c)",q_stop
        print*,"E min  (kev)",e_start
        print*,"E max  (kev)",e_stop
        print*,"Rel. error tolerance",error

    end subroutine
end module totaleventrate


      REAL FUNCTION tfreez(salinity)
C     Constants taken from Gill, 1982.
C     Author: Robert Grumbine
C     LAST MODIFIED: 1 February 2002.
C          MODIFIED: 21 September 1994.

      IMPLICIT none

      REAL salinity
      REAL a1, a2, a3
      PARAMETER (a1 = -0.0575)
      PARAMETER (a2 =  1.710523E-3)
      PARAMETER (a3 = -2.154996E-4)

      IF (salinity .LT. 0.) THEN
        tfreez = 0.
CD        PRINT *,'tfreez was passed a negative salinity',salinity
        salinity = 1.e-5
      ELSE
        tfreez = salinity*(a1+a2*SQRT(salinity)+a3*salinity)
      ENDIF

      RETURN
      END


!	Find estimated conditional expectations and conditional covariance matrices for transformed latent vectors.
!	covtheta is the array of conditional covariance matrices.
!	lintran is the linear transformation for the latent vector.
!	meantheta is the array of conditional means.
!	covnewtheta is the array of transformed conditional covariances.
!	meannewtheta is the  array of transformed conditional means.
subroutine eapskill(covtheta,lintran,meantheta,covnewtheta,meannewtheta)
implicit none
real(kind=8),intent(in)::covtheta(:,:,:),lintran(:,:),meantheta(:,:)
real(kind=8),intent(out)::covnewtheta(:,:,:),meannewtheta(:,:)
!	obs is observation number.
integer::obs
!	Set up parameter arrays for simplified processing.
do obs=1,size(meantheta,2)
	covnewtheta(:,:,obs)=matmul(lintran,matmul(covtheta(:,:,obs),transpose(lintran)))
	meannewtheta(:,obs)=matmul(lintran,meantheta(:,obs))

end do

return
end subroutine eapskill


C$Procedure      KPSOLV ( Solve Keplers Equation --- Vector Form )

      DOUBLE PRECISION FUNCTION KPSOLV ( EVEC )

C$ Abstract
C
C    This routine solves the equation X = < EVEC, U(X) > where
C    U(X) is the unit vector [ Cos(X), SIN(X) ] and  < , > denotes
C    the two-dimensional dot product.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     ROOTS
C
C$ Declarations

      IMPLICIT NONE
      DOUBLE PRECISION      EVEC ( 2 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     EVEC       I   A 2-vector whose magnitude is less than 1.
C
C     The function returns the solution to X = < EVEC, U(X) >
C
C$ Detailed_Input
C
C     EVEC       is any two dimensional vector whose magnitude is
C                less than 1.
C
C$ Detailed_Output
C
C     The function returns the value X such that the equation
C
C        X = EVEC(1)COS(X) + EVEC(2)SIN(X).
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     1) If the magnitude of EVEC is greater than or equal to 1
C        the error SPICE(EVECOUTOFRANGE) is signalled.
C
C$ Particulars
C
C     This routine uses bisection and Newton's method to find
C     the root of the equation
C
C        X = EVEC(1)COS(X) + EVEC(2)SIN(X).
C
C     This equation is just a "vector form" of Kepler's equation.
C
C
C$ Examples
C
C     Suppose you need to solve the equation
C
C         M = E - e SIN(E)                           [ 1 ]
C
C     for E. If we let X = E - M the equation is transformed to
C
C        0 = X - e SIN( X + M )
C
C          = X - e SIN( M ) COS(X) - e COS(M) SIN ( X )
C
C     Thus if we solve the equation
C
C        X = e SIN(M) COS(X) + e COS(M) SIN(X)
C
C     we can find the value of X we can compute E.
C
C     The code fragment below illustrates how this routine can
C     be used to solve equation [1].
C
C         EVEC(1) = ECC * DSIN(M)
C         EVEC(2) = ECC * DCOS(M)
C         E       = M   + KPSOLV( EVEC )
C
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 26-AUG-1997 (WLT)
C
C        KPSOLV is now given an initial value of zero so that
C        if an error condition is detected, KPSOLV will have
C        a return value.
C
C-    SPICELIB Version 1.0.0, 03-JAN-1997 (WLT)
C
C-&

C$ Index_Entries
C
C     Solve the vector form of the Kepler equation
C
C-&

C
C     MXNEWT is the number of iterations we will perform
C     in the Newtons method for finding the solution to
C     the vector form of Kepler's equation.  It has been
C     empirically determined that 5 iterations is always
C     sufficient on computers have 64 bit double precision
C     numbers.
C
      INTEGER               MXNEWT
      PARAMETER           ( MXNEWT = 5 )

      DOUBLE PRECISION      COSX
      DOUBLE PRECISION      ECC
      DOUBLE PRECISION      ECC2
      DOUBLE PRECISION      H
      DOUBLE PRECISION      K
      DOUBLE PRECISION      SINX
      DOUBLE PRECISION      X
      DOUBLE PRECISION      XL
      DOUBLE PRECISION      XM
      DOUBLE PRECISION      XU
      DOUBLE PRECISION      Y0
      DOUBLE PRECISION      YPX
      DOUBLE PRECISION      YX
      DOUBLE PRECISION      YXM

      INTEGER               I
      INTEGER               MAXIT

C
C     We give the function an initial value, just in case
C     we exit without solving Kepler's equation.
C
      KPSOLV = 0.0D0

      H      = EVEC(1)
      K      = EVEC(2)

      ECC2   = H*H + K*K

      IF ( ECC2 .GE. 1.0D0 ) THEN

         CALL CHKIN  ( 'KPSOLV' )
         CALL SETMSG ( 'The magnitude of the vector EVEC = ( #, '
     .   //            '# ) must be less than 1.  However, the '
     .   //            'magnitude of this vector is #.' )

         CALL ERRDP  ( '#', H           )
         CALL ERRDP  ( '#', K           )
         CALL ERRDP  ( '#', DSQRT(ECC2) )

         CALL SIGERR ( 'SPICE(EVECOUTOFRANGE)'  )
         CALL CHKOUT ( 'KPSOLV' )
         RETURN

      END IF

C
C     We first approximate the equation 0 = X - H * COS(X) - K * SIN(X)
C     using bisection.  If we let Y(X) = X - H * COS(X) - K * SIN(X)
C
C        Y( ECC) =  ECC - <EVEC,U(X)>  =   ECC - ECC*COS(ANGLE_X) > 0
C        Y(-ECC) = -ECC - <EVEC,U(X)>  =  -ECC - ECC*COS(ANGLE_X) < 0
C
C     where ANGLE_X is the angle between U(X) and EVEC. Thus -ECC
C     and ECC necessarily bracket the root of the equation Y(X) = 0.
C
C     Also note that Y'(X) = 1 - < EVEC, V(X) > where V(X) is the
C     unit vector given by U'(X).  Thus Y is an increasing function
C     over the interval from -ECC to ECC.
C
C     The mid point of ECC and -ECC is 0 and Y(0) = -H.  Thus
C     we can do the first bisection step without doing
C     much in the way of computations.
C

      Y0  = -H
      XM  =  0.0D0
      ECC =  DSQRT(ECC2)

      IF      ( Y0 .GT. 0.0D0 ) THEN

         XU  =  0.0D0
         XL  = -ECC

      ELSE IF ( Y0 .LT. 0.0D0 ) THEN

         XU =  ECC
         XL =  0.0D0

      ELSE

         KPSOLV = 0.0D0
         RETURN

      END IF
C
C     Iterate until we are assured of being in a region where
C     Newton's method will converge quickly.  The formula
C     below was empirically determined to give good results.
C
      MAXIT = MIN(32, MAX( 1, NINT(1.0D0/(1.0D0-ECC)) ) )

      DO I = 1, MAXIT

C
C        Compute the next midpoint.  We bracket XM by XL and XU just in
C        case some kind of strange rounding occurs in the computation
C        of the midpoint.
C
         XM     = MAX( XL, MIN( XU, 0.5D0*(XL + XU) ) )

C
C        Compute Y at the midpoint of XU and XL
C
         YXM = XM - H*COS(XM) - K*SIN(XM)
C
C        Determine the new upper and lower bounds.
C
         IF ( YXM .GT. 0.0D0 ) THEN
            XU = XM
         ELSE
            XL = XM
         END IF

      END DO

C
C     We've bisected into a region where we can now get rapid
C     convergence using Newton's method.
C
      X   = XM

      DO I = 1, MXNEWT

         COSX = DCOS(X)
         SINX = DSIN(X)
C
C        Compute Y and Y' at X.  Use these to get the next
C        iteration for X.
C
C        For those of you who might be wondering, "Why not put
C        in a check for YX .EQ. 0 and return early if we get
C        an exact solution?"  Here's why.  An empirical check
C        of those cases where you can actually escape from the
C        Do-loop  showed that the test YX .EQ. 0 is true
C        only about once in every 10000 case of random inputs
C        of EVEC.  Thus on average the check is a waste of
C        time and we don't bother with it.
C
         YX   = X     - H*COSX - K*SINX
         YPX  = 1.0D0 + H*SINX - K*COSX
         X    = X     - YX/YPX

      END DO

      KPSOLV = X

      RETURN
      END


c***************************************************************************
c			OBL_POT.F
c*************************************************************************
c OBL_POT returns the total potential in the barycentric frame for NBOD
c particles due to the oblateness of mass(1) using
c the values of J2RP2 and J4RP4 passed into the routine.
c (J2RP2 for example is the product of
c J_2 times the square of the central body's radius)
c Here we return the potential produced
c only by the J2 and J4 terms (i.e. including
c neither the monopole nor higher order terms).
c
c
c             Input:
c                 nbod     ==>  number of massive bodies (incl. central one)
c                 mass(*)  ==>  masses of particles (real*8 array)
c                 j2rp2    ==>  scaled value of j2 moment (real*8 scalar)
c                 j4rp4    ==>  scaled value of j4 moment (real*8 scalar)
c                 xh(*),yh(*),zh(*)   ==>  HELIO. positions of particles
c                                    (real*8 vectors)
c                 irh(*)   ==> 1./ magnitude of radius vector (real*8 vector)
c                                (passed in to save calcs.)
c
c             Output:
c                 oblpot  ==>  BARY. potential
c                                        (real*8 scalar)
c
c Remarks:
c Authors:  Martin Duncan
c Date:    3/4/94
c Last revision:

      subroutine obl_pot(nbod,mass,j2rp2,j4rp4,xh,yh,zh,irh,
     &                oblpot)

      include '../swift.inc'

c...  Inputs Only:
      integer nbod
      real*8 mass(NPLMAX)
      real*8 j2rp2,j4rp4
      real*8 xh(NPLMAX),yh(NPLMAX),zh(NPLMAX),irh(NPLMAX)

c...  Output
      real*8 oblpot

c...  Internals
      integer n
      real*8 rinv2,t0,t1,t2,t3
      real*8 p2,p4

c----
c...  executable code

c Sum all the the bary terms for each "planet" due to central oblate "sun"

	oblpot = 0.d0
	do n =2,nbod

c Note that here we assume we know inverse of radius rather than calc. it
c from (x,y,z) to save the sqrt.
	  rinv2= irh(n)**2
	  t0 = mass(1)*mass(n)*rinv2*irh(n)
	  t1 = j2rp2
	  t2 = zh(n)*zh(n)*rinv2
	  t3 = j4rp4*rinv2

	  p2 = 0.5d0*(3.d0*t2 - 1.d0)
	  p4 = 0.125d0*( (35.d0*t2 -30.d0)*t2 +3.d0)

	  oblpot = oblpot + t0*(t1*p2 + t3*p4)

	enddo

        return
        end                       !  obl_pot.f
c____________________________________________________________________________


program teste
    use NobleNeuron

    implicit none

    integer,parameter   :: dp = kind(1.d0)
    type(NeuralNetwork) :: XOR
    integer             :: i,j
    real                :: r,r1,r2
    real(dp)            :: sample(2,1)
    real(dp)            :: expected(1,1)
    double precision    :: L
    real(dp)            :: gL(1,1)

    !--------------------------------------------------!
    !              Create Neural Network               !
    !--------------------------------------------------!
    XOR = NeuralNetwork(2,"L2","SGD")
    i = XOR%addLayer(3,"Sigmoid")
    i = XOR%addLayer(1,"Sigmoid")

    !--------------------------------------------------!
    !                 Train Network                    !
    !--------------------------------------------------!
    L = 1.0
    do while(L > 0.01)
        ! Epoch = 4 runs
        L = 0.0
        do j = 1,4
            ! Input vector: 00,01,10,11 + noise
            call random_number(r)
            call random_number(r1)
            call random_number(r2)
            r1 = (r1-0.5)/5
            r2 = (r2-0.5)/5
            i = 1 + floor(4*r)

            select case(i)
                case(1)
                    sample = reshape([real(dp) :: r1,r2], shape(sample))
                    expected = reshape([real(dp) :: 0], shape(expected))
                case(2)
                    sample = reshape([real(dp) :: r1,1+r2], shape(sample))
                    expected = reshape([real(dp) :: 1], shape(expected))
                case(3)
                    sample = reshape([real(dp) :: 1+r1,r2], shape(sample))
                    expected = reshape([real(dp) :: 1], shape(expected))
                case(4)
                    sample = reshape([real(dp) :: 1+r1,1+r2], shape(sample))
                    expected = reshape([real(dp) :: 0], shape(expected))
            end select

            ! Feedforward / Loss / Backpropagation
            call XOR%feedforward(sample)
            L = L + XOR%Loss(expected)
            gL = XOR%gradLoss(expected)
            call XOR%backpropagate(sample,gL)
        end do

        ! Plot loss and apply gradients
        write(*,*) L/4
        call XOR%applyGrads(0.001)
    end do

    !--------------------------------------------------!
    !                  Show Results                    !
    !--------------------------------------------------!
    write(*,*)
    write(*,*) "=========================================="
    write(*,*) "                 RESULTS                  "
    write(*,*) "=========================================="
    write(*,*)

    sample = reshape([real(dp) :: 0,0],shape(sample))
    call XOR%feedforward(sample)
    write(*,*) "00 -> ",XOR%output()

    sample = reshape([real(dp) :: 0,1],shape(sample))
    call XOR%feedforward(sample)
    write(*,*) "01 -> ",XOR%output()

    sample = reshape([real(dp) :: 1,0],shape(sample))
    call XOR%feedforward(sample)
    write(*,*) "10 -> ",XOR%output()

    sample = reshape([real(dp) :: 1,1],shape(sample))
    call XOR%feedforward(sample)
    write(*,*) "11 -> ",XOR%output()
    write(*,*)

end program


      module MOD_MOMO

      contains

      SUBROUTINE MOMO (OPA,ETA,THOMSON,EDDI,R,XJC,A,B,C,W,ND)
C***  SOLUTION OF THE MOMENT EQUATION **********************************
! Calculates, intent(out),  A,B,C,W, XJC
! input parameters intent(in), are EDDI, OPA, ETA, THOMSO, R,
!	CALLTREE
!	MOMO:
!     | -> INVTRI, line 55	inverts the triangular matrix [A,B,C], changes C
      use MOD_INVTRI
	IMPLICIT NONE
      integer,intent(in):: ND
	real*8,intent(out),dimension(ND) :: A, B, C, W, XJC
	real*8,intent(in),dimension(ND)  :: ETA, OPA, THOMSON, R
	real*8,intent(in),dimension(3,ND):: EDDI

 	real*8 :: DA, DC, DR, DX, FL, FM, FP, QL, QM, QP, H, HPLUS
	real*8 :: RL, X
	integer:: L, NDM

      real*8,parameter:: one=1.0d0, two=2.d0, four=4.0d0

C***  OUTER BOUNDARY
      FL=EDDI(1,1)
      QL=EDDI(2,1)
      H =EDDI(3,1)
      FP=EDDI(1,2)
      QP=EDDI(2,2)
      RL=R(1)
      X=OPA(1)
      DX=(QL+QP)*(X+OPA(2))*(RL-R(2))/four
      B(1)=two*QL*QL*FL*X/DX/DX+two*QL*X*H/DX+X*(one-THOMSON(1))
      C(1)=two*QL*QP*FP*X/DX/DX
      W(1)=RL*RL*ETA(1)

C***  NON-BOUNDARY POINTS
      NDM=ND-1
      DO  L=2,ND-1
		FL=EDDI(1,L)
		QL=EDDI(2,L)
		FP=EDDI(1,L+1)
		QP=EDDI(2,L+1)
		FM=EDDI(1,L-1)
		QM=EDDI(2,L-1)
		X=OPA(L)
		RL=R(L)
		DR=(R(L-1)-R(L+1))/two
		DA=DR*(R(L-1)-RL)*(QM+QL)*(OPA(L-1)+X)/four
		DC=DR*(RL-R(L+1))*(QP+QL)*(OPA(L+1)+X)/four
		A(L)=QM*FM/DA
		C(L)=QP*FP/DC
		B(L)=QL*FL*(one/DA+one/DC)+X*(one-THOMSON(L))
		W(L)=RL*RL*ETA(L)
	ENDDO

C***  INNER BOUNDARY
      FL=EDDI(1,ND)
      QL=EDDI(2,ND)
      H =EDDI(3,ND)
      HPLUS=EDDI(3,ND-1)
      FM=EDDI(1,ND-1)
      QM=EDDI(2,ND-1)
      RL=R(ND)
      X=OPA(ND)
      DX=(QM+QL)*(X+OPA(ND-1))*(R(ND-1)-R(ND))/four
      A(ND)=two*QL*QM*FM*X/DX/DX
      B(ND)=two*QL*QL*FL*X/DX/DX+two*QL*X*H/DX+X*(one-THOMSON(ND))
      W(ND)=RL*RL*(ETA(ND)+two*QL*X*HPLUS/DX)

      CALL INVTRI(A,B,C,W,ND)
      DO L=1,ND
      	RL=R(L)
    		XJC(L)=W(L)/RL/RL
    	ENDDO
      RETURN
      END subroutine
      end module