c
c     This file contains the translation operators for the helmholtz
c     3D FMM
c
c     h3dmpmp - shift center of multipole expansion
c     h3dmploc - convert multipole expansion to a local expansion
c     h3dlocloc - shift center of local expansion
c
C***********************************************************************
      subroutine h3dmpmp(nd,wavek,sc1,x0y0z0,mpole,nterms,
     1           sc2,xnynzn,mpolen,nterms2,
     2           radius,xnodes,wts,nquad)
C***********************************************************************
C
C
C     Usage:
C
C           Shift center of multipole expansion mpole, and add output
C           multipole expansion.
C           This is a reasonably fast "point and shoot" version which
C           first rotates the coordinate system, then shifts
C           along the Z-axis, and then rotates back to the original
C           coordinates.
C
C           NOTE: the output multipole expansion is not initialized
C              in this routine and the shifted
C              multipole expansion is directly added to it
C
C
C
C---------------------------------------------------------------------
C     INPUT:
C
C           nd     = number of multipole expansions
C           wavek  = Helmholtz parameter
C           sc1     = scaling parameter for mpole expansion
C           x0y0z0 = center of original multiple expansion
C           mpole  = coefficients of original multiple expansion
C           nterms = order of multipole expansion
C           sc2     = scaling parameter for shifted expansion
C           xnynzn = center of shifted expansion
C           nterms2 = order of shifted expansion
C           radius  = radius of sphere on which mpole expansion is
C                     computed
C           xnodes  = Legendre nodes (precomputed)
C           wts     = Legendre weights (precomputed)
C           nquad   = number of quadrature nodes in theta direction
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C           mpolen = coefficients of shifted mpole expansion
C
C
C***********************************************************************
      implicit none
c
cc      calling sequence variables
c
      integer  nterms,nterms2,nquad,nd
      real *8 x0y0z0(3),xnynzn(3)
      real *8 radius,xnodes(nquad),wts(nquad)
      real *8 sc1,sc2
      complex *16 wavek
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      complex *16 mpolen(nd,0:nterms2,-nterms2:nterms2)

c
cc      temporary variables
c
      complex *16, allocatable :: marray(:,:,:),marray1(:,:,:)
      complex *16, allocatable :: mptemp(:,:,:),mp2(:,:,:)
      complex *16, allocatable :: ephi(:),phitemp(:,:,:)
      complex *16, allocatable :: phitempn(:,:,:)
      complex *16, allocatable :: fhs(:),fhder(:)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16 imag

      integer  nq, ldc,idim
      real *8 rshift
      real *8 d,theta,ctheta,phi,rvec(3)
      integer  l,m,jnew,knew

      data imag/(0.0d0,1.0d0)/
C
      ldc = max(nterms,nterms2)
      nq = max(nquad,2*ldc+2)

      allocate(marray(nd,0:ldc,-ldc:ldc))
      allocate(marray1(nd,0:nterms,-nterms:nterms))
      allocate(mptemp(nd,0:nterms2,-nterms2:nterms2))
      allocate(mp2(nd,0:nterms2,-nterms2:nterms2))
      allocate(ephi(-ldc-1:ldc+1))
      allocate(phitemp(nd,nq,-ldc:ldc))
      allocate(phitempn(nd,nq,-ldc:ldc))
      allocate(fhs(0:ldc),fhder(0:ldc))
      allocate(ynm(0:ldc,0:ldc),ynmd(0:ldc,0:ldc))

C
      rvec(1) = xnynzn(1) - x0y0z0(1)
      rvec(2) = xnynzn(2) - x0y0z0(2)
      rvec(3) = xnynzn(3) - x0y0z0(3)

      call cart2polar(rvec,d,theta,phi)

      ephi(1) = exp(imag*phi)
      ephi(0)=1.0d0
      ephi(-1)=dconjg(ephi(1))
c
c----- create array of powers e^(i*m*phi).
c
      do l = 1,ldc
         ephi(l+1) = ephi(l)*ephi(1)
         ephi(-1-l) = dconjg(ephi(l+1))
      enddo
c
c----- a rotation of THETA radians about the Yprime axis after PHI
c      radians about the z-axis.
c      The PHI rotation is carried out on the fly by multiplying
c      mpole and ephi inside the following loop.
c
      do l=0,nterms
         do m=-l,l
            do idim=1,nd
               marray1(idim,l,m)=mpole(idim,l,m)*ephi(m)
            enddo
         enddo
      enddo

      if( nterms .ge. 30 ) then
         call rotviaproj(nd,theta,nterms,nterms,nterms,marray1,
     1         nterms,marray,ldc)
      else
         call rotviarecur(nd,theta,nterms,nterms,nterms,marray1,
     1           nterms,marray,ldc)
      endif

c
c
c----- shift the mpole expansion from X0Y0Z0 to XNYNZN along
c      the Z-axis.
c
      do l=0,nterms2
         do m=-l,l
           do idim=1,nd
              mptemp(idim,l,m) = 0
              mp2(idim,l,m) = 0
           enddo
         enddo
      enddo

      rshift = d
      call h3dmpmpzshift
     $   (nd,wavek,sc1,marray,ldc,nterms,sc2,mptemp,
     1           nterms2,nterms2,radius,rshift,xnodes,wts,nquad,
     2           ynm,ynmd,mp2,phitemp,phitempn,fhs,fhder)
c
c
c     Reverse THETA rotation.
c     I.e. rotation of -THETA radians about Yprime axis.
c
      if( nterms2 .ge. 30 ) then
         call rotviaproj(nd,-theta,nterms2,nterms,nterms2,mptemp,
     1           nterms2,marray,ldc)
      else
         call rotviarecur(nd,-theta,nterms2,nterms2,nterms2,mptemp,
     1           nterms2,marray,ldc)
      endif
c
c
c----- rotate back PHI radians about the Z-axis in the above system
c         and add to existing expansion mpolen
c
      do l=0,nterms2
         do m=-l,l
            do idim=1,nd
              mpolen(idim,l,m)=mpolen(idim,l,m) +
     1           ephi(-m)*marray(idim,l,m)
            enddo
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c***********************************************************************
      subroutine h3dmpmpzshift
     $     (nd,zk,scale,mpole,lmp,nterms,scale2,mpolen,
     1      lmpn,nterms2,radius,zshift,xnodes,wts,nquad,ynm,
     2      ynmd,mp2,phitemp,phitempn,fhs,fhder)
c***********************************************************************
c
c     This subroutine converts a multipole expansion centered at the
c     origin to a multipole expansion centered at (0,0,zhift).
c     The expansion is rescaled to that of the shifted expansion.
c
c INPUT:
c
c     nd       : number of multipole expansions
c     zk       : Helmholtz coefficient
c     scale    : scale parameter for mpole
c     mpole    : coefficients of original multipole exp.
c     lmp      : leading dim of mpole (may be a work array)
c     nterms   : number of terms in the orig. expansion
c
c     scale2   : scale parameter for new expansion (mpolen)
c     lmpn     : leading dim of shifted (may be work array)
c     nterms2  : number of terms in output expansion
c     radius   : radius of sphere on which mpole is evaluated
c                           in projeciton step
c     zshift   : shifting distance along z-axis
c                              (always assumed positive)
C     xnodes   : Legendre nodes (precomputed)
C     wts      : Legendre weights (precomputed)
C     nquad    : number of quadrature nodes in theta direction
c
c OUTPUT:
c
c     mpolen  (complex *16)  : coefficients of shifted exp.
c
c***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nterms,nterms2,nquad,ier,lmp,lmpn,ldc,iynm,lynm,nd
      real *8   zshift,scale,scale2,radius
      real *8   xnodes(*),wts(*)
      real *8   ynm(0:nterms,0:nterms)
      real *8   ynmd(0:nterms,0:nterms)
      complex *16 phitemp(nd,nquad,-nterms:nterms)
      complex *16 phitempn(nd,nquad,-nterms:nterms)
      complex *16 fhs(0:nterms2)
      complex *16 fhder(0:nterms2)
      complex *16 mpole(nd,0:lmp,-lmp:lmp),zk
      complex *16 mpolen(nd,0:lmpn,-lmpn:lmpn)
      complex *16 mp2(nd,0:lmpn,-lmpn:lmpn)
c
c     local allocated workspace arrays - no more passed workspace
c
      real *8, allocatable :: rat1(:,:),rat2(:,:)
c
      integer l,m,jnew,knew
C
C----- shift along z-axis by evaluating field on target sphere and
C     projecting onto spherical harmonics and scaling by j_n(kR).
C
C    OPTIMIZATION NOTES:
C
C    Suppose you are shifting from a very small sphere to the center
C    of a very large sphere (nterms2 >> nterms).
C    Then, ALONG THE Z-AXIS, the number of azimuthal modes that
C    need to be computed is only nterms (not nterms2).
C    Subroutines h3dmpevalspherenm, h3dprojlocnmsep allow for this.
C    The final step of the point and shoot algorithm then distributes
C    these nterms (azimuthal) modes to nterms2 (azimuthal) in the
C    "laboratory frame".
C
C    cost is (nterms^2 x nterms2) rather than (nterms x nterms2^2)
C

        ldc = max(nterms,nterms2)

        allocate(rat1(0:ldc,0:ldc))
        allocate(rat2(0:ldc,0:ldc))

      call h3dmpevalsphere(nd,mpole,zk,scale,
     1     zshift,radius,nterms,lmp,ynm,ynmd,
     2     phitemp,phitempn,nquad,xnodes,fhs,fhder,rat1,rat2)
      call h3dprojloc
     $   (nd,nterms2,lmpn,nquad,nterms,xnodes,wts,
     1     phitemp,phitempn,mpolen,mp2,ynm,rat1,rat2)
      call h3drescalemp(nd,nterms2,lmpn,mpolen,radius,zk,
     1               scale2,fhs,fhder)
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h3dmploc(nd,wavek,sc1,x0y0z0,mpole,nterms,
     1           sc2,xnynzn,local,nterms2,
     2           radius,xnodes,wts,nquad)
C***********************************************************************
C
C           Converts multipole expansion and adds to a local expansion
C           This is a reasonably fast "point and shoot" version which
C           first rotates the coordinate system, then shifts along
C           the Z-axis, and then rotates back to the original
C           coordinates.
C
C           NOTE: the output local expansion is not initialized
C              in this routine and the shifted
C              multipole expansion is directly added to it
C
C---------------------------------------------------------------------
C     INPUT:
C
C           nd     = number of expansions
C           wavek  = Helmholtz parameter
C           sc1     = scaling parameter for mpole expansion
C           x0y0z0 = center of original multiple expansion
C           mpole  = coefficients of original multiple expansion
C           nterms = order of multipole expansion
C           sc2     = scaling parameter for local expansion
C           xnynzn = center of shifted local expansion
C           nterms2 = order of local expansion
C           radius  = radius of sphere on which local expansion is
C                     computed
C           xnodes  = Legendre nodes (precomputed)
C           wts     = Legendre weights (precomputed)
C           nquad   = number of quadrature nodes in theta direction.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C           local = coefficients of shifted local expansion
C
C***********************************************************************
C
      implicit none

c
cc       calling sequence variables

      integer nterms,nterms2,nquad,nd
      real *8 x0y0z0(3),xnynzn(3)
      real *8 xnodes(nquad),wts(nquad),radius
      real *8 sc1,sc2
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      complex *16 local(nd,0:nterms2,-nterms2:nterms2)
      complex *16 wavek

c
cc      temporary variables
c
      complex *16, allocatable :: marray(:,:,:),marray1(:,:,:)
      complex *16, allocatable :: mptemp(:,:,:),mp2(:,:,:)
      complex *16, allocatable :: ephi(:),phitemp(:,:,:)
      complex *16, allocatable :: phitempn(:,:,:)
      complex *16, allocatable :: fhs(:),fhder(:)
      complex *16, allocatable :: fjs(:),fjder(:)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16 imag

      integer  nq, ldc,idim
      real *8 rshift
      real *8 d,theta,ctheta,phi,rvec(3)
      integer  l,m,jnew,knew
c
      data imag/(0.0d0,1.0d0)/
C
      ldc = max(nterms,nterms2)
      nq = max(nquad,2*ldc+2)

      allocate(marray(nd,0:ldc,-ldc:ldc))
      allocate(mp2(nd,0:ldc,-ldc:ldc))
      allocate(marray1(nd,0:nterms,-nterms:nterms))
      allocate(mptemp(nd,0:nterms2,-nterms2:nterms2))
      allocate(ephi(-ldc-1:ldc+1))
      allocate(phitemp(nd,nq,-ldc:ldc))
      allocate(phitempn(nd,nq,-ldc:ldc))
      allocate(fhs(0:ldc),fhder(0:ldc))
      allocate(ynm(0:ldc,0:ldc),ynmd(0:ldc,0:ldc))
      allocate(fjs(0:nterms2),fjder(0:nterms2))

C
      rvec(1) = xnynzn(1) - x0y0z0(1)
      rvec(2) = xnynzn(2) - x0y0z0(2)
      rvec(3) = xnynzn(3) - x0y0z0(3)
      call cart2polar(rvec,d,theta,phi)
c
      ephi(1) = exp(imag*phi)
      ephi(0)=1.0d0
      ephi(-1)=dconjg(ephi(1))
c
c     create array of powers e^(i*m*phi).
c
      do l = 1,ldc
         ephi(l+1) = ephi(l)*ephi(1)
         ephi(-1-l) = dconjg(ephi(l+1))
      enddo
c
c     a rotation of THETA radians about the Yprime axis after PHI
c     radians about the z-axis.
      do l=0,nterms
         do m=-l,l
            do idim=1,nd
               marray1(idim,l,m)  = mpole(idim,l,m)*ephi(m)
            enddo
         enddo
      enddo

      do l=0,nterms2
         do m=-l,l
            do idim=1,nd
               mptemp(idim,l,m)=0.0d0
            enddo
         enddo
      enddo

c
      if( nterms .ge. 30 ) then
         call rotviaproj(nd,theta,nterms,nterms,nterms,marray1,
     1       nterms,marray,ldc)
      else
         call rotviarecur(nd,theta,nterms,nterms,nterms,marray1,
     1          nterms,marray,ldc)
      endif

c
c----- shift the local expansion from X0Y0Z0 to XNYNZN along
c      the Z-axis.
c
      rshift = d
      call h3dmploczshift(nd,wavek,marray,sc1,ldc,nterms,mptemp,
     1      sc2,nterms2,nterms2,radius,rshift,xnodes,wts,nquad,
     2      ynm,ynmd,mp2,phitemp,phitempn,fhs,fhder,fjs,fjder)

c
c     reverse THETA rotation.
c     I.e. rotation of -THETA radians about the Yprime axis.
c
      if( nterms2 .ge. 30 ) then
         call rotviaproj(nd,-theta,nterms2,nterms2,nterms2,mptemp,
     1          nterms2,marray,ldc)
      else
         call rotviarecur(nd,-theta,nterms2,nterms2,nterms2,mptemp,
     1          nterms2,marray,ldc)
      endif
c
c----- rotate back PHI radians about the Z-axis in the above system.
c
      do l=0,nterms2
         do m=-l,l
            do idim=1,nd
               local(idim,l,m)=local(idim,l,m) +
     1             ephi(-m)*marray(idim,l,m)
            enddo
         enddo
      enddo

      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine h3dmploczshift
     $     (nd,zk,mpole,scale,lmp,nterms,local,
     1      scale2,lmpn,nterms2,radius,zshift,xnodes,wts,nquad,
     2      ynm,ynmd,mp2,phitemp,phitempn,fhs,fhder,fjs,fjder)
c***********************************************************************
c
c     This subroutine converts a multipole expansion centered at the
c     origin to a local expansion centered at (0,0,zhift).
c     The expansion is rescaled to that of the local expansion.
c
C---------------------------------------------------------------------
c     INPUT:
c
c     nd       : number of expansions
c     zk       : Helmholtz parameter
c     mpole    : coefficients of original multipole exp.
c     scale    : scale parameter for mpole
c     lmp      : leading dim of mpole (may be a work array)
c     nterms   : number of terms in original expansion
c
c     scale2   : scale parameter for local
c     lmpn     : leading dim of local (may be a work array)
c     nterms2  : number of terms in output local exp.
c     radius   : radius of sphere about new center on which field
c                is evaluated
c     zshift   : shifting distance along z-axis
c                             (always assumed positive)
C     xnodes  = Legendre nodes (precomputed)
C     wts     = Legendre weights (precomputed)
C     nquad   = number of quadrature nodes in theta direction.
c
C---------------------------------------------------------------------
c     OUTPUT:
c
c     local    : coefficients of shifted local exp.
c
C---------------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      integer nterms,nterms2,nquad,nd
      integer l,lw,m,jnew,knew
      real *8 zshift
      real *8 xnodes(*),wts(*)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      complex *16 phitemp(nd,nquad,-nterms:nterms)
      complex *16 phitempn(nd,nquad,-nterms:nterms)
      complex *16 mp2(nd,0:lmpn,-lmpn:lmpn)
      complex *16 fhs(0:nterms)
      complex *16 fhder(0:nterms)
      complex *16 fjs(0:nterms2)
      complex *16 fjder(0:nterms2)
      complex *16 mpole(nd,0:lmp,-lmp:lmp),zk
      complex *16 local(nd,0:lmpn,-lmpn:lmpn)
c
c     local allocated workspace array
c
      real *8, allocatable :: rat1(:,:),rat2(:,:)
c

        ldc = max(nterms,nterms2)
        allocate(rat1(0:ldc,0:ldc))
        allocate(rat2(0:ldc,0:ldc))
C
C----- shift along z-axis by evaluating field on target sphere and
C     projecting onto spherical harmonics and scaling by j_n(kR).
C
      call h3dmpevalsphere(nd,mpole,zk,scale,zshift,radius,
     2     nterms,lmp,ynm,ynmd,phitemp,phitempn,nquad,xnodes,
     3     fhs,fhder,rat1,rat2)
      call h3dprojloc
     $   (nd,nterms2,lmpn,nquad,nterms,xnodes,wts,
     1     phitemp,phitempn,local,mp2,ynm,rat1,rat2)
      call h3drescaleloc(nd,nterms2,lmpn,local,mp2,radius,zk,scale2,
     2     fjs,fjder)

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine h3dlocloc(nd,wavek,sc1,x0y0z0,locold,nterms,
     1           sc2,xnynzn,local,nterms2,
     2           radius,xnodes,wts,nquad)
C***********************************************************************
C
C
C     Usage:
C
C           Shift center of a local expansion and add to output local
C           expansion.
C           This is a reasonably fast "point and shoot" version which
C           first rotates the coordinate system, then shifts along
C           the Z-axis, and then rotates back to the original
C           coordinates.
C
C           NOTE: the output local expansion is not initialized
C              in this routine and the shifted
C              local expansion is directly added to it
C
C     Input:
C
C           nd     = number of local expansions
C           wavek  = Helmholtz parameter
C           sc1     = scaling parameter for locold expansion
C           x0y0z0 = center of original expansion
C           locold  = coefficients of original expansion
C           nterms = order of original expansion
C           sc2     = scaling parameter for local expansion
C           xnynzn = center of shifted expansion
C
C           nterms2 = order of shifted expansion
C           radius  = radius of sphere on which local expansion is
C                     computed
C           xnodes  = Legendre nodes (precomputed)
C           wts     = Legendre weights (precomputed)
C           nquad   = number of quadrature nodes used (really nquad**2)
C                     should be about 2*nterms2
C
C     Output:
C
C           local = coefficients of shifted expansion
C
C***********************************************************************
      implicit none

c
cc      calling sequence variables
c
      integer nterms,nterms2,nquad,nd
      real *8 x0y0z0(3),xnynzn(3)
      real *8 xnodes(nquad),wts(nquad),radius
      real *8 sc1,sc2
      complex *16 locold(nd,0:nterms,-nterms:nterms)
      complex *16 local(nd,0:nterms2,-nterms2:nterms2)
      complex *16 wavek
c
cc      temporary variables
c
      complex *16, allocatable :: marray(:,:,:),marray1(:,:,:)
      complex *16, allocatable :: mptemp(:,:,:),mp2(:,:,:)
      complex *16, allocatable :: ephi(:),phitemp(:,:,:)
      complex *16, allocatable :: phitempn(:,:,:)
      complex *16, allocatable :: fjs(:),fjder(:)
      real *8, allocatable :: ynm(:,:),ynmd(:,:)
      complex *16 imag, ephi1

      integer  nq, ldc,idim
      real *8 rshift
      real *8 d,theta,ctheta,phi,rvec(3)
      integer  l,m,jnew,knew
c
      data imag/(0.0d0,1.0d0)/
C
      ldc = max(nterms,nterms2)
      nq = max(nquad,2*ldc+2)

      allocate(marray(nd,0:ldc,-ldc:ldc))
      allocate(mp2(nd,0:ldc,-ldc:ldc))
      allocate(marray1(nd,0:nterms,-nterms:nterms))
      allocate(mptemp(nd,0:nterms2,-nterms2:nterms2))
      allocate(ephi(-ldc-1:ldc+1))
      allocate(phitemp(nd,nq,-ldc:ldc))
      allocate(phitempn(nd,nq,-ldc:ldc))
      allocate(ynm(0:ldc,0:ldc),ynmd(0:ldc,0:ldc))

      allocate(fjs(0:ldc),fjder(0:ldc))
C
      rvec(1) = xnynzn(1) - x0y0z0(1)
      rvec(2) = xnynzn(2) - x0y0z0(2)
      rvec(3) = xnynzn(3) - x0y0z0(3)
      call cart2polar(rvec,d,theta,phi)
c
      ephi1 = exp(imag*phi)
      ephi(0)=1.0d0
      ephi(1)=ephi1
      ephi(-1)=dconjg(ephi1)
c
c----- create array of powers e^(i*m*phi).
c
      do l = 1,ldc
         ephi(l+1) = ephi(l)*ephi(1)
         ephi(-1-l) = dconjg(ephi(l+1))
      enddo
c
c
c      a rotation of THETA radians about the Yprime-axis after PHI
c      radians about the z-axis.
c      The PHI rotation is carried out on the fly by multiplying
c      locold and ephi inside the following loop.
c

      do l=0,nterms
         do m=-l,l
            do idim=1,nd
               marray1(idim,l,m) = locold(idim,l,m)*ephi(m)
            enddo
         enddo
      enddo
      do l=0,nterms2
         do m=-l,l
            do idim=1,nd
               mptemp(idim,l,m)=0.0d0
            enddo
         enddo
      enddo

      if( nterms .ge. 30 ) then
         call rotviaproj(nd,theta,nterms,nterms,nterms2,marray1,
     1      nterms,marray,ldc)
      else
         call rotviarecur(nd,theta,nterms,nterms,nterms2,marray1,
     1         nterms,marray,ldc)
      endif
c
c----- shift the local expansion from X0Y0Z0 to XNYNZN along
c      the Z-axis.
c
      rshift = d
       call h3dlocloczshift(nd,wavek,sc1,marray,ldc,nterms,sc2,mptemp,
     1       nterms2,nterms2,radius,rshift,xnodes,wts,nquad,ynm,ynmd,
     2       mp2,phitemp,phitempn,fjs,fjder)

c
c      reverse THETA rotation.
c      I.e. rotation of -THETA about Yprime axis.
c
      if( nterms2 .ge. 30 ) then
         call rotviaproj(nd,-theta,nterms2,nterms2,nterms2,mptemp,
     1         nterms2,marray,ldc)
      else
         call rotviarecur(nd,-theta,nterms2,nterms2,nterms2,mptemp,
     1         nterms2,marray,ldc)
      endif
c
c----- rotate back PHI radians about the Z-axis in the above system.
c
      do l=0,nterms2
         do m=-l,l
            do idim=1,nd
               local(idim,l,m)=local(idim,l,m) +
     1            ephi(-m)*marray(idim,l,m)
            enddo
         enddo
      enddo

      return
      end
c
c
c
c
c***********************************************************************
      subroutine h3dlocloczshift
     $     (nd,zk,scale,locold,lmp,nterms,scale2,
     1      local,lmpn,nterms2,radius,zshift,xnodes,wts,nquad,
     2      ynm,ynmd,mp2,phitemp,phitempn,fjs,fjder)
c***********************************************************************
c
c     This subroutine converts a multipole expansion centered at the
c     origin to a local expansion centered at (0,0,zhift).
c     The expansion is rescaled to that of the local expansion.
c
c     INPUT:
c
c     nd       : number of local expansions
c     zk       : Helmholtz parameter
c     scale    : scaling parameter for locold
c     locold   : coefficients of original multipole exp.
c     lmp      : leading dim of locold (may be a work array)
c     nterms   : number of terms in the orig. expansion
c     scale2   : scaling parameter for output expansion (local)
c
c     lmpn     : leading dim of local (may be a work array)
c     nterms2  : number of terms in output local exp.
C     radius   : radius of sphere on which local expansion is
C                computed
c     zshift   : shifting distance along z-axis (assumed positive)
C     xnodes   : Legendre nodes (precomputed)
C     wts      : Legendre weights (precomputed)
C     nquad    : number of quadrature nodes used (really nquad**2)
C                     should be about 2*nterms2
c
c     OUTPUT:
c
c     local    : coefficients of shifted local exp.
c     ier      : error return code
c                 CURRENTLY NOT USED
c
c***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nterms,nterms2,nquad,ier,l,lw,m,jnew,knew,nd
      real *8 zshift
      real *8 xnodes(nquad),wts(nquad)
      real *8 ynm(0:lmp,0:lmp)
      real *8 ynmd(0:lmp,0:lmp)
      complex *16 phitemp(nd,nquad,-nterms2:nterms2)
      complex *16 phitempn(nd,nquad,-nterms2:nterms2)
      complex *16 mp2(nd,0:lmp,-lmp:lmp)
      complex *16 fjs(0:lmp)
      complex *16 fjder(0:lmp)
      complex *16 locold(nd,0:lmp,-lmp:lmp),zk
      complex *16 local(nd,0:lmpn,-lmpn:lmpn)
c
c     local allocated workspace arrays - no more passed workspace
c
      real *8, allocatable :: w(:)
c

        ldc = max(nterms,nterms2)
        irat1=1
        lrat1=(ldc+1)**2
        irat2=irat1+lrat1
        lrat2=(ldc+1)**2
        lused=irat2+lrat2
        allocate (w(lused))
C
C
C----- shift along z-axis by evaluating field on target sphere and
C     projecting onto spherical harmonics and scaling by j_n(kR).
C
C    OPTIMIZATION NOTES:
C
C    Suppose you are shifting from a very large sphere to a very
C    small sphere (nterms >> nterms2).
C    Then, ALONG THE Z-AXIS, the number of azimuthal modes that
C    need to be computed is only nterms2 (not nterms).
C    Subroutines h3dlocevalspherestab, h3dprojlocsepstab allow for this.
C
C    cost is (nterms2^2 x nterms) rather than (nterms2 x nterms^2)
C
C
C

      call h3dlocevalsphere(nd,locold,zk,scale,
     1      zshift,radius,nterms,nterms2,
     1     lmp,ynm,ynmd,phitemp,phitempn,nquad,xnodes,fjs,
     1     fjder,w(irat1),w(irat2))

      call h3dprojloc
     $   (nd,nterms2,lmpn,nquad,nterms2,xnodes,wts,
     1     phitemp,phitempn,local,mp2,ynm,w(irat1),w(irat2))

      call h3drescaleloc(nd,nterms2,lmpn,local,mp2,
     1      radius,zk,scale2,fjs,fjder)

      return
      end
C
C


!======================================================================================================================
!> @file        pascal_tdma.f90
!> @brief       PaScaL_TDMA - Parallel and Scalable Library for TriDiagonal Matrix Algorithm
!> @details     PaScal_TDMA provides an efficient and scalable computational procedure
!>              to solve many tridiagonal systems in multi-dimensional partial differential equations.
!>              The modified Thomas algorithm proposed by Laszlo et al.(2016) and the newly designed communication
!>              scheme have been used to reduce the communication overhead in solving many tridiagonal systems.
!>              This library is for both single and many tridiagonal systems of equations.
!>              The main algorithm for a tridiagonal matrix consists of the following five steps:
!>
!>              (1) Transform the partitioned submatrices in the tridiagonal systems into modified submatrices:
!>                  Each computing core transforms the partitioned submatrices in the tridiagonal systems
!>                  of equations into modified forms by applying the modified Thomas algorithm.
!>              (2) Construct reduced tridiagonal systems from the modified submatrices:
!>                  The reduced tridiagonal systems are constructed by collecting the first and last rows
!>                  of the modified submatrices from each core using MPI_Ialltoallw.
!>              (3) Solve the reduced tridiagonal systems:
!>                  The reduced tridiagonal systems constructed in Step 2 are solved by applying the Thomas algorithm.
!>              (4) Distribute the solutions of the reduced tridiagonal systems:
!>                  The solutions of the reduced tridiagonal systems in Step 3 are distributed to each core
!>                  using MPI_Ialltoallw. This communication is an exact inverse of the communication in Step 2.
!>              (5) Update the other unknowns in the modified tridiagonal systems:
!>                  The remaining unknowns in the modified submatrices in Step 1 are solved in each computing core
!>                  using the solutions obtained in Step 3 and Step 4.
!>
!>              Step 1 and Step 5 are similar to the method proposed by Laszlo et al.(2016)
!>              which uses parallel cyclic reduction (PCR) algorithm to build and solve the reduced tridiagonal systems.
!>              Instead of using the PCR, we develop an all-to-all communication scheme using the MPI_Ialltoall
!>              function after the modified Thomas algorithm is executed. The number of coefficients for
!>              the reduced tridiagonal systems are greatly reduced, so we can avoid the communication
!>              bandwidth problem, which is a main bottleneck for all-to-all communications.
!>              Our algorithm is also distinguished from the work of Mattor et al. (1995) which
!>              assembles the undetermined coefficients of the temporary solutions in a single processor
!>              using MPI_Gather, where load imbalances are serious.
!>
!> @author
!>              - Kiha Kim (k-kiha@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>              - Jung-Il Choi (jic@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>
!> @date        June 2019
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2019 Kiha Kim and Jung-Il choi, Yonsei University and
!>              Ji-Hoon Kang, Korea Institute of Science and Technology Information, All rights reserved.
!> @par         License
!>              This project is released under the terms of the MIT License (see LICENSE )
!======================================================================================================================

!>
!> @brief       Module for PaScaL-TDMA library.
!> @details     It contains plans for tridiagonal systems of equations and subroutines for solving them
!>              using the defined plans. The operation of the library includes the following three phases:
!>              (1) Create a data structure called a plan, which has the information for communication and reduced systems.
!>              (2) Solve the tridiagonal systems of equations executing from Step 1 to Step 5
!>              (3) Destroy the created plan
!>
module PaScaL_TDMA

    use mpi

    implicit none

    !> @brief   Execution plan for many tridiagonal systems of equations.
    !> @details It uses MPI_Ialltoallw function to distribute the modified tridiagonal systems to MPI processes
    !>          and build the reduced tridiagonal systems of equations. Derived datatypes are defined and used
    !>          to eliminate the cost of data packing and unpacking.
    type, public :: ptdma_plan_many

        integer :: ptdma_world      !< Single dimensional subcommunicator to assemble data for the reduced TDMA
        integer :: n_sys_rt         !< Number of tridiagonal systems that need to be solved in each process after transpose
        integer :: n_row_rt         !< Number of rows of a reduced tridiagonal systems after transpose

        !> @{ Send buffer related variables for MPI_Ialltoallw
        integer, allocatable, dimension(:) :: ddtype_FS, count_send, displ_send
        !> @}

        !> @{ Recv. buffer related variables MPI_Ialltoallw
        integer, allocatable, dimension(:) :: ddtype_BS, count_recv, displ_recv
        !> @}

        !> @{ Coefficient arrays after reduction, a: lower, b: diagonal, c: upper, d: rhs.
        !>    The orginal dimension (m:n) is reduced to (m:2)
        double precision, allocatable, dimension(:,:) :: A_rd, B_rd, C_rd, D_rd
        !> @}

        !> @{ Coefficient arrays after transpose of reduced systems, a: lower, b: diagonal, c: upper, d: rhs
        !>    The reduced dimension (m:2) changes to (m/np: 2*np) after transpose.
        double precision, allocatable, dimension(:,:) :: A_rt, B_rt, C_rt, D_rt
        !> @}

    end type ptdma_plan_many

    !> @brief   Execution plan for a single tridiagonal system of equations.
    !> @details It uses the MPI_Igather function to build the reduced tridiagonal system of equations
    !>          to a specified MPI process.
    type, public :: ptdma_plan_single

        integer :: ptdma_world          !< Single dimensional subcommunicator to assemble data for the reduced TDMA
        integer :: n_row_rt             !< Number of rows of a reduced tridiagonal system after MPI_Gather

        integer :: gather_rank          !< Destination rank of MPI_Igather
        integer :: myrank               !< Current rank ID in the communicator of ptdma_world

        !> @{ Coefficient arrays after reduction, a: lower, b: diagonal, c: upper, d: rhs.
        !>    The orginal dimension (n) is reduced to (2)
        double precision, allocatable, dimension(:) :: A_rd, B_rd, C_rd, D_rd
        !> @}

        !> @{ Coefficient arrays after transpose of a reduced system, a: lower, b: diagonal, c: upper, d: rhs
        !>    The reduced dimension (2) changes to (2*np) after transpose.
        double precision, allocatable, dimension(:) :: A_rt, B_rt, C_rt, D_rt   !< Coefficient arrays, a: lower, b: diagonal, c: upper, d: rhs
        !> @}

    end type ptdma_plan_single

    private

    public  :: PaScaL_TDMA_plan_single_create
    public  :: PaScaL_TDMA_plan_single_destroy
    public  :: PaScaL_TDMA_single_solve
    public  :: PaScaL_TDMA_single_solve_cycle

    public  :: PaScaL_TDMA_plan_many_create
    public  :: PaScaL_TDMA_plan_many_destroy
    public  :: PaScaL_TDMA_many_solve
    public  :: PaScaL_TDMA_many_solve_cycle

    contains

    !>
    !> @brief   Create a plan for a single tridiagonal system of equations.
    !> @param   plan        Plan for a single tridiagonal system of equations
    !> @param   myrank      Rank ID in mpi_world
    !> @param   nprocs      Number of MPI process in mpi_world
    !> @param   mpi_world   Communicator for MPI_Gather and MPI_Scatter of a reduced system
    !> @param   gather_rank Target rank where all coefficients are gathered to
    !>
    subroutine PaScaL_TDMA_plan_single_create(plan, myrank, nprocs, mpi_world, gather_rank)

        implicit none

        type(ptdma_plan_single), intent(inout)  :: plan
        integer, intent(in)     :: myrank, nprocs, mpi_world, gather_rank

        integer                 :: nr_rd    ! Number of rows of a reduced tridiagonal system per process, 2
        integer                 :: nr_rt    ! Number of rows of a reduced tridiagonal system after MPI_Gather

        nr_rd = 2
        nr_rt = nr_rd*nprocs

        plan%myrank = myrank
        plan%gather_rank = gather_rank
        plan%ptdma_world = mpi_world
        plan%n_row_rt = nr_rt

        allocate( plan%A_rd(1:nr_rd), plan%B_rd(1:nr_rd), plan%C_rd(1:nr_rd), plan%D_rd(1:nr_rd) )
        allocate( plan%A_rt(1:nr_rt), plan%B_rt(1:nr_rt), plan%C_rt(1:nr_rt), plan%D_rt(1:nr_rt) )

    end subroutine PaScaL_TDMA_plan_single_create

    !>
    !> @brief   Deallocate the allocated arrays in the defined plan_single .
    !> @param   plan        Plan for a single tridiagonal system of equations
    !>
    subroutine PaScaL_TDMA_plan_single_destroy(plan)

        implicit none

        type(ptdma_plan_single), intent(inout)  :: plan

        deallocate(plan%A_rd, plan%B_rd, plan%C_rd, plan%D_rd)
        deallocate(plan%A_rt, plan%B_rt, plan%C_rt, plan%D_rt)

    end subroutine PaScaL_TDMA_plan_single_destroy

    !>
    !> @brief   Create a plan for many tridiagonal systems of equations.
    !> @param   plan        Plan for a single tridiagonal system of equations
    !> @param   n_sys       Number of tridiagonal systems of equations for process
    !> @param   myrank      Rank ID in mpi_world
    !> @param   nprocs      Number of MPI process in mpi_world
    !> @param   mpi_world   Communicator for MPI_Gather and MPI_Scatter of reduced equations
    !>
    subroutine PaScaL_TDMA_plan_many_create(plan, n_sys, myrank, nprocs, mpi_world)

        implicit none

        type(ptdma_plan_many), intent(inout)  :: plan
        integer, intent(in)     :: n_sys
        integer, intent(in)     :: myrank, nprocs, mpi_world

        integer :: i, ierr
        integer :: ista, iend                               ! First and last indices of assigned range in many tridiagonal systems of equations
        integer :: bigsize(2), subsize(2), start(2)         ! Temporary variables of derived data type (DDT)
        integer :: ns_rd, nr_rd                             ! Dimensions of many reduced tridiagonal systems
        integer :: ns_rt, nr_rt                             ! Dimensions of many reduced tridiagonal systems after transpose
        integer, allocatable, dimension(:):: ns_rt_array    ! Array specifying the number of tridiagonal systems for each process after transpose

        ! Specify dimensions for reduced systems.
        ns_rd = n_sys
        nr_rd = 2

        ! Specify dimensions for reduced systems after transpose.
        ! ns_rt         : divide the number of tridiagonal systems of equations per each process
        ! ns_rt_array   : save the ns_rt in ns_rt_array for defining the DDT
        ! nr_rt         : dimensions of the reduced tridiagonal systems in the solving direction, nr_rd*nprocs
        call para_range(1, ns_rd, nprocs, myrank, ista, iend)
        ns_rt = iend - ista + 1
        allocate(ns_rt_array(0:nprocs-1))
        call MPI_Allgather(ns_rt, 1, mpi_integer, ns_rt_array,1, mpi_integer, mpi_world, ierr)
        nr_rt = nr_rd*nprocs

        ! Assign plan variables and allocate coefficient arrays.
        plan%n_sys_rt = ns_rt
        plan%n_row_rt = nr_rt
        plan%ptdma_world = mpi_world

        allocate( plan%A_rd(1:ns_rd, 1:nr_rd) )
        allocate( plan%B_rd(1:ns_rd, 1:nr_rd) )
        allocate( plan%C_rd(1:ns_rd, 1:nr_rd) )
        allocate( plan%D_rd(1:ns_rd, 1:nr_rd) )
        allocate( plan%A_rt(1:ns_rt, 1:nr_rt) )
        allocate( plan%B_rt(1:ns_rt, 1:nr_rt) )
        allocate( plan%C_rt(1:ns_rt, 1:nr_rt) )
        allocate( plan%D_rt(1:ns_rt, 1:nr_rt) )

        ! Building the DDTs.
        allocate(plan%ddtype_Fs(0:nprocs-1),  plan%ddtype_Bs(0:nprocs-1))

        do i=0,nprocs-1
            ! DDT for sending coefficients of the reduced tridiagonal systems using MPI_Ialltoallw communication.
            bigsize(1)=ns_rd
            bigsize(2)=nr_rd
            subsize(1)=ns_rt_array(i)
            subsize(2)=nr_rd
            start(1)=sum(ns_rt_array(0:i)) - ns_rt_array(i)
            start(2)=0
            call MPI_Type_create_subarray(  2, bigsize, subsize, start,                     &
                                            MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION,        &
                                            plan%ddtype_Fs(i), ierr )
            call MPI_Type_commit(plan%ddtype_Fs(i), ierr)
            ! DDT for receiving coefficients for the transposed systems of reduction using MPI_Ialltoallw communication.
            bigsize(1)=ns_rt
            bigsize(2)=nr_rt
            subsize(1)=ns_rt
            subsize(2)=nr_rd
            start(1)=0
            start(2)=nr_rd*i
            call MPI_Type_create_subarray(  2, bigsize, subsize, start,                     &
                                            MPI_ORDER_FORTRAN, MPI_DOUBLE_PRECISION,        &
                                            plan%ddtype_Bs(i), ierr )
            call MPI_Type_commit(plan%ddtype_Bs(i), ierr)
        enddo

        ! Buffer counts and displacements for MPI_Ialltoallw.
        ! All buffer counts are 1 and displacements are 0 due to the defined DDT.
        allocate(plan%count_send(0:nprocs-1), plan%displ_send(0:nprocs-1))
        allocate(plan%count_recv(0:nprocs-1), plan%displ_recv(0:nprocs-1))
        plan%count_send=1; plan%displ_send=0
        plan%count_recv=1; plan%displ_recv=0

        ! Deallocate local array.
        if(allocated(ns_rt_array)) deallocate(ns_rt_array)

    end subroutine PaScaL_TDMA_plan_many_create

    !>
    !> @brief   Destroy the allocated arrays in the defined plan_many.
    !> @param   plan        Plan for many tridiagonal systems of equations
    !>
    subroutine PaScaL_TDMA_plan_many_destroy(plan,nprocs)
        implicit none

        type(ptdma_plan_many), intent(inout)  :: plan
        integer :: i,nprocs,ierr

        do i=0,nprocs-1
            call MPI_TYPE_FREE(plan%ddtype_Fs(i), ierr)
            call MPI_TYPE_FREE(plan%ddtype_Bs(i), ierr)
        enddo

        deallocate(plan%ddtype_Fs,  plan%ddtype_Bs)
        deallocate(plan%count_send, plan%displ_send)
        deallocate(plan%count_recv, plan%displ_recv)
        deallocate(plan%A_rd, plan%B_rd, plan%C_rd, plan%D_rd)
        deallocate(plan%A_rt, plan%B_rt, plan%C_rt, plan%D_rt)

    end subroutine PaScaL_TDMA_plan_many_destroy

    !>
    !> @brief   Solve a single tridiagonal system of equation.
    !> @param   plan        Plan for a single tridiagonal system of equation
    !> @param   A           Coefficients in lower diagonal elements
    !> @param   B           Coefficients in diagonal elements
    !> @param   C           Coefficients in upper diagonal elements
    !> @param   D           Coefficients in right-hand side terms
    !> @param   n_row       Number of rows in each process, size of a tridiagonal matrix N divided by nprocs
    !>
    subroutine PaScaL_TDMA_single_solve(plan, A, B, C, D, n_row)

        implicit none

        type(ptdma_plan_single), intent(inout)   :: plan
        double precision,   intent(inout)   :: A(1:n_row), B(1:n_row), C(1:n_row), D(1:n_row)
        integer, intent(in) :: n_row

        ! Temporary variables for computation and parameters for MPI functions
        double precision :: r
        integer :: i
        integer :: request(4), ierr

        ! Reduction step : elimination of lower diagonal elements
        A(1) = A(1)/B(1)
        D(1) = D(1)/B(1)
        C(1) = C(1)/B(1)

        A(2) = A(2)/B(2)
        D(2) = D(2)/B(2)
        C(2) = C(2)/B(2)

        do i=3,n_row
            r    =  1.d0/(B(i)-A(i)*C(i-1))
            D(i) =  r*(D(i)-A(i)*D(i-1))
            C(i) =  r*C(i)
            A(i) = -r*A(i)*A(i-1)
        enddo

        ! Reduction step : elimination of upper diagonal elements
        do i=n_row-2,2,-1
            D(i) = D(i)-C(i)*D(i+1)
            A(i) = A(i)-C(i)*A(i+1)
            C(i) =-C(i)*C(i+1)
        enddo

        r = 1.d0/(1.d0-A(2)*C(1))
        D(1) =  r*(D(1)-C(1)*D(2))
        A(1) =  r*A(1)
        C(1) = -r*C(1)*C(2)

        ! Construct a reduced tridiagonal system of equations per each rank. Each process has two reduced rows.
        plan%A_rd(1) = A(1); plan%A_rd(2) = A(n_row)
        plan%B_rd(1) = 1.d0; plan%B_rd(2) = 1.d0
        plan%C_rd(1) = C(1); plan%C_rd(2) = C(n_row)
        plan%D_rd(1) = D(1); plan%D_rd(2) = D(n_row)

        ! Gather the coefficients of the reduced tridiagonal system to a defined rank, plan%gather_rank.
        call MPI_Igather(plan%A_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%A_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(1), ierr)
        call MPI_Igather(plan%B_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%B_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(2), ierr)
        call MPI_Igather(plan%C_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%C_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(3), ierr)
        call MPI_Igather(plan%D_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%D_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(4), ierr)
        call MPI_Waitall(4, request, MPI_STATUSES_IGNORE, ierr)

        ! Solve the reduced tridiagonal system on plan%gather_rank.
        if(plan%myrank == plan%gather_rank) then
            call tdma_single(plan%A_rt,plan%B_rt,plan%C_rt,plan%D_rt, plan%n_row_rt)
        endif

        ! Scatter the solutions to each rank.
        call MPI_Iscatter(plan%D_rt, 2, MPI_DOUBLE_PRECISION, &
                          plan%D_rd, 2, MPI_DOUBLE_PRECISION, &
                          plan%gather_rank, plan%ptdma_world, request(1), ierr)

        call MPI_Waitall(1, request, MPI_STATUSES_IGNORE, ierr)

        ! Update solutions of the modified tridiagonal system with the solutions of the reduced tridiagonal system.
        D(1 ) = plan%D_rd(1)
        D(n_row) = plan%D_rd(2)
        do i=2,n_row-1
            D(i) = D(i)-A(i)*D(1)-C(i)*D(n_row)
        enddo

    end subroutine PaScaL_TDMA_single_solve

    !>
    !> @brief   Solve a single cyclic tridiagonal system of equations.
    !> @param   plan        Plan for a single tridiagonal system of equations
    !> @param   A           Coefficients in lower diagonal elements
    !> @param   B           Coefficients in diagonal elements
    !> @param   C           Coefficients in upper diagonal elements
    !> @param   D           Coefficients in right-hand side terms
    !> @param   n_row       Number of rows in each process, size of a tridiagonal matrix N divided by nprocs
    !>
    subroutine PaScaL_TDMA_single_solve_cycle(plan, A, B, C, D, n_row)

        implicit none

        type(ptdma_plan_single), intent(inout)   :: plan
        double precision, intent(inout)     :: A(1:n_row), B(1:n_row), C(1:n_row), D(1:n_row)
        integer, intent(in)                 :: n_row

        ! Temporary variables for computation and parameters for MPI functions.
        integer :: i, request(4), ierr
        double precision :: rr

        ! The modified Thomas algorithm : elimination of lower diagonal elements.
        A(1) = A(1)/B(1)
        D(1) = D(1)/B(1)
        C(1) = C(1)/B(1)

        A(2) = A(2)/B(2)
        D(2) = D(2)/B(2)
        C(2) = C(2)/B(2)

        do i=3,n_row
            rr = 1.d0/(B(i)-A(i)*C(i-1))
            D(i) =  rr*(D(i)-A(i)*D(i-1))
            C(i) =  rr*C(i)
            A(i) = -rr*A(i)*A(i-1)
        enddo

        ! The modified Thomas algorithm : elimination of upper diagonal elements.
        do i=n_row-2,2,-1
            D(i) =  D(i)-C(i)*D(i+1)
            A(i) =  A(i)-C(i)*A(i+1)
            C(i) = -C(i)*C(i+1)
        enddo

        rr = 1.d0/(1.d0-A(2)*C(1))
        D(1) =  rr*(D(1)-C(1)*D(2))
        A(1) =  rr*A(1)
        C(1) = -rr*C(1)*C(2)

        ! Construct a reduced tridiagonal system of equations per each rank. Each process has two reduced rows.
        plan%A_rd(1) = A(1); plan%A_rd(2) = A(n_row)
        plan%B_rd(1) = 1.d0; plan%B_rd(2) = 1.d0
        plan%C_rd(1) = C(1); plan%C_rd(2) = C(n_row)
        plan%D_rd(1) = D(1); plan%D_rd(2) = D(n_row)

        ! Gather the coefficients of the reduced tridiagonal system to a defined rank, plan%gather_rank.
        call MPI_Igather(plan%A_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%A_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(1), ierr)
        call MPI_Igather(plan%B_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%B_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(2), ierr)
        call MPI_Igather(plan%C_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%C_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(3), ierr)
        call MPI_Igather(plan%D_rd, 2, MPI_DOUBLE_PRECISION, &
                         plan%D_rt, 2, MPI_DOUBLE_PRECISION, &
                         plan%gather_rank, plan%ptdma_world, request(4), ierr)

        call MPI_Waitall(4, request, MPI_STATUSES_IGNORE, ierr)

        ! Solve the reduced cyclic tridiagonal system on plan%gather_rank.
        if(plan%myrank == plan%gather_rank) then
            call tdma_cycl_single(plan%A_rt,plan%B_rt,plan%C_rt,plan%D_rt, plan%n_row_rt)
        endif

        ! Distribute the solutions to each rank.
        call MPI_Iscatter(plan%D_rt, 2, MPI_DOUBLE_PRECISION, &
                          plan%D_rd, 2, MPI_DOUBLE_PRECISION, &
                          plan%gather_rank, plan%ptdma_world, request(1), ierr)

        call MPI_Waitall(1, request, MPI_STATUSES_IGNORE, ierr)

        ! Update solutions of the modified tridiagonal system with the solutions of the reduced tridiagonal system.
        D(1 ) = plan%D_rd(1)
        D(n_row) = plan%D_rd(2)

        do i=2, n_row-1
            D(i) = D(i)-A(i)*D(1)-C(i)*D(n_row)
        enddo

    end subroutine PaScaL_TDMA_single_solve_cycle

    !>
    !> @brief   Solve many tridiagonal systems of equations.
    !> @param   plan        Plan for many tridiagonal systems of equations
    !> @param   A           Coefficients in lower diagonal elements
    !> @param   B           Coefficients in diagonal elements
    !> @param   C           Coefficients in upper diagonal elements
    !> @param   D           Coefficients in right-hand side terms
    !> @param   n_sys       Number of tridiagonal systems per process
    !> @param   n_row       Number of rows in each process, size of a tridiagonal matrix N divided by nprocs
    !>
    subroutine PaScaL_TDMA_many_solve(plan, A, B, C, D, n_sys, n_row)

        implicit none

        type(ptdma_plan_many), intent(inout)   :: plan
        double precision, intent(inout)     :: A(1:n_sys,1:n_row), B(1:n_sys,1:n_row), C(1:n_sys,1:n_row), D(1:n_sys,1:n_row)
        integer, intent(in)                 :: n_sys, n_row

        ! Temporary variables for computation and parameters for MPI functions.
        integer :: i, j
        integer :: request(4),ierr
        double precision :: r

        ! The modified Thomas algorithm : elimination of lower diagonal elements.
        ! First index indicates a number of independent many tridiagonal systems to use vectorization.
        ! Second index indicates a row number in a partitioned tridiagonal system .
        do i=1, n_sys
            A(i,1) = A(i,1)/B(i,1)
            D(i,1) = D(i,1)/B(i,1)
            C(i,1) = C(i,1)/B(i,1)

            A(i,2) = A(i,2)/B(i,2)
            D(i,2) = D(i,2)/B(i,2)
            C(i,2) = C(i,2)/B(i,2)
        enddo

        do j=3, n_row
            do i=1, n_sys
                r    =    1.d0/(B(i,j)-A(i,j)*C(i,j-1))
                D(i,j) =  r*(D(i,j)-A(i,j)*D(i,j-1))
                C(i,j) =  r*C(i,j)
                A(i,j) = -r*A(i,j)*A(i,j-1)
            enddo
        enddo

        ! The modified Thomas algorithm : elimination of upper diagonal elements.
        do j=n_row-2, 2, -1
            do i=1, n_sys
                D(i,j) = D(i,j)-C(i,j)*D(i,j+1)
                A(i,j) = A(i,j)-C(i,j)*A(i,j+1)
                C(i,j) =-C(i,j)*C(i,j+1)
            enddo
        enddo

        do i=1, n_sys
            r = 1.d0/(1.d0-A(i,2)*C(i,1))
            D(i,1) =  r*(D(i,1)-C(i,1)*D(i,2))
            A(i,1) =  r*A(i,1)
            C(i,1) = -r*C(i,1)*C(i,2)

            ! Construct many reduced tridiagonal systems per each rank. Each process has two rows of reduced systems.
            plan%A_rd(i,1) = A(i,1); plan%A_rd(i,2) = A(i,n_row)
            plan%B_rd(i,1) = 1.d0  ; plan%B_rd(i,2) = 1.d0
            plan%C_rd(i,1) = C(i,1); plan%C_rd(i,2) = C(i,n_row)
            plan%D_rd(i,1) = D(i,1); plan%D_rd(i,2) = D(i,n_row)
        enddo

        ! Transpose the reduced systems of equations for TDMA using MPI_Ialltoallw and DDTs.
        call MPI_Ialltoallw(plan%A_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%A_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(1), ierr)
        call MPI_Ialltoallw(plan%B_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%B_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(2), ierr)
        call MPI_Ialltoallw(plan%C_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%C_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(3), ierr)
        call MPI_Ialltoallw(plan%D_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%D_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(4), ierr)

        call MPI_Waitall(4, request, MPI_STATUSES_IGNORE, ierr)

        ! Solve the reduced tridiagonal systems of equations using Thomas algorithm.
        call tdma_many(plan%A_rt,plan%B_rt,plan%C_rt,plan%D_rt, plan%n_sys_rt, plan%n_row_rt)

        ! Transpose the obtained solutions to original reduced forms using MPI_Ialltoallw and DDTs.
        call MPI_Ialltoallw(plan%D_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%D_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%ptdma_world, request(1), ierr)
        call MPI_Waitall(1, request, MPI_STATUSES_IGNORE, ierr)

        ! Update solutions of the modified tridiagonal system with the solutions of the reduced tridiagonal system.
        do i=1,n_sys
            D(i,1 ) = plan%D_rd(i,1)
            D(i,n_row) = plan%D_rd(i,2)
        enddo

        do j=2,n_row-1
            do i=1,n_sys
                D(i,j) = D(i,j)-A(i,j)*D(i,1)-C(i,j)*D(i,n_row)
            enddo
        enddo

    end subroutine PaScaL_TDMA_many_solve

    !>
    !> @brief   Solve many cyclic tridiagonal systems of equations.
    !> @param   plan        Plan for many tridiagonal systems of equations
    !> @param   A           Coefficients in lower diagonal elements
    !> @param   B           Coefficients in diagonal elements
    !> @param   C           Coefficients in upper diagonal elements
    !> @param   D           Coefficients in right-hand side terms
    !> @param   n_sys       Number of tridiagonal systems per process
    !> @param   n_row       Number of rows in each process, size of a tridiagonal matrix N divided by nprocs
    !>
    subroutine PaScaL_TDMA_many_solve_cycle(plan, A, B, C, D, n_sys, n_row)

        implicit none

        type(ptdma_plan_many), intent(inout)   :: plan
        double precision, intent(inout)     :: A(1:n_sys,1:n_row), B(1:n_sys,1:n_row), C(1:n_sys,1:n_row), D(1:n_sys,1:n_row)
        integer, intent(in)                 :: n_sys, n_row

        ! Temporary variables for computation and parameters for MPI functions.
        integer :: i,j
        integer :: request(4), ierr
        double precision :: r

        ! The modified Thomas algorithm : elimination of lower diagonal elements.
        ! First index indicates a number of independent many tridiagonal systems to use vectorization.
        ! Second index indicates a row number in a partitioned tridiagonal system.
        do i=1,n_sys
            A(i,1) = A(i,1)/B(i,1)
            D(i,1) = D(i,1)/B(i,1)
            C(i,1) = C(i,1)/B(i,1)

            A(i,2) = A(i,2)/B(i,2)
            D(i,2) = D(i,2)/B(i,2)
            C(i,2) = C(i,2)/B(i,2)
        enddo

        do j=3,n_row
            do i=1,n_sys
                r =    1.d0/(B(i,j)-A(i,j)*C(i,j-1))
                D(i,j) =  r*(D(i,j)-A(i,j)*D(i,j-1))
                C(i,j) =  r*C(i,j)
                A(i,j) = -r*A(i,j)*A(i,j-1)
            enddo
        enddo

        ! The modified Thomas algorithm : elimination of upper diagonal elements.
        do j=n_row-2,2,-1
            do i=1,n_sys
                D(i,j) = D(i,j)-C(i,j)*D(i,j+1)
                A(i,j) = A(i,j)-C(i,j)*A(i,j+1)
                C(i,j) =-C(i,j)*C(i,j+1)
            enddo
        enddo

        do i=1,n_sys
            r = 1.d0/(1.d0-A(i,2)*C(i,1))
            D(i,1) =  r*(D(i,1)-C(i,1)*D(i,2))
            A(i,1) =  r*A(i,1)
            C(i,1) = -r*C(i,1)*C(i,2)

            ! Construct the reduced tridiagonal equations per each rank. Each process has two rows of reduced systems.
            plan%A_rd(i,1) = A(i,1); plan%A_rd(i,2) = A(i,n_row)
            plan%B_rd(i,1) = 1.d0  ; plan%B_rd(i,2) = 1.d0
            plan%C_rd(i,1) = C(i,1); plan%C_rd(i,2) = C(i,n_row)
            plan%D_rd(i,1) = D(i,1); plan%D_rd(i,2) = D(i,n_row)
        enddo

        ! Transpose the reduced systems of equations for TDMA using MPI_Ialltoallw and DDTs.
        call MPI_Ialltoallw(plan%A_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%A_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(1), ierr)
        call MPI_Ialltoallw(plan%B_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%B_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(2), ierr)
        call MPI_Ialltoallw(plan%C_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%C_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(3), ierr)
        call MPI_Ialltoallw(plan%D_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%D_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%ptdma_world, request(4), ierr)

        call MPI_Waitall(4, request, MPI_STATUSES_IGNORE, ierr)

        ! Solve the reduced cyclic tridiagonal systems of equations using cyclic TDMA.
        call tdma_cycl_many(plan%A_rt, plan%B_rt, plan%C_rt, plan%D_rt, plan%n_sys_rt, plan%n_row_rt)

        ! Transpose the obtained solutions to original reduced forms using MPI_Ialltoallw and DDTs.
        call MPI_Ialltoallw(plan%D_rt, plan%count_recv, plan%displ_recv, plan%ddtype_Bs, &
                            plan%D_rd, plan%count_send, plan%displ_send, plan%ddtype_Fs, &
                            plan%ptdma_world, request(1), ierr)
        call MPI_Waitall(1, request, MPI_STATUSES_IGNORE, ierr)

        ! Update solutions of the modified tridiagonal system with the solutions of the reduced tridiagonal system.
        do i=1,n_sys
            D(i,1 ) = plan%D_rd(i,1)
            D(i,n_row) = plan%D_rd(i,2)
        enddo

        do j=2,n_row-1
            do i=1,n_sys
                D(i,j) = D(i,j)-A(i,j)*D(i,1)-C(i,j)*D(i,n_row)
            enddo
        enddo

    end subroutine PaScaL_TDMA_many_solve_cycle

end module PaScaL_TDMA


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of alfa in forward (tangent) mode:
!   variations   of useful results: alfa
!   with respect to varying inputs: x
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief truncated series expansion of cosh(x) for x < 0.1
!>    @param[in] x input value
!>    @return truncated function value
DOUBLE PRECISION FUNCTION g_ALFA(x, g_x, alfa)
  IMPLICIT NONE
  DOUBLE PRECISION :: x
  DOUBLE PRECISION :: g_x
  INTRINSIC ABS
  INTRINSIC TANH
  DOUBLE PRECISION :: abs0
  DOUBLE PRECISION :: temporary
  DOUBLE PRECISION :: temporary0
  DOUBLE PRECISION :: alfa
!      double precision x2, x3, x5, x7
  alfa = 0.d0
  IF (x .GE. 0.) THEN
    abs0 = x
  ELSE
    abs0 = -x
  END IF
  IF (abs0 .GT. 1.d-30) THEN
    temporary = TANH(x)
    temporary0 = (x/temporary-1.d0)/x
    g_alfa = ((1.0-x*(1.0-TANH(x)**2)/temporary)/temporary-temporary0)*g_x/x
    alfa = temporary0
  ELSE
    g_alfa = 0.D0
  END IF
!      if (abs(x).lt.1.d-1) then
!         x2 = x*x
!         x3 = x2*x
!         x5 = x3*x2
!         x7 = x5*x2
!         alfa = x/3.d0 - x3/4.5d1 + 2.d0*x5/9.45d2 -
!     & x7/4.725d3
!         alfa = x*3.333333333333333d-01
!     &        - x3*2.222222222222222d-02
!     &        + x5*2.116402116402117d-03
!     &        - x7*2.116402116402116e-04
!      else
!         alfa=(x/tanh(x) - 1.d0)/x
!      endif
  RETURN
END FUNCTION g_ALFA


!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine full_multigrid(icount)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  !
  integer::ilevel,icount
  logical::multigrid=.false.

  ! Exit routine if no self-gravity
  if(gravity_type>0)return

  ! Compute rho for all coarser levels using restriction operator
  do ilevel=levelmin-1,1,-1
     call restriction_fine(ilevel,multigrid)
  end do

  ! Compute potential and acceleration for all coarser levels
  do ilevel=1,levelmin-1
     call multigrid_coarse(ilevel,icount)
     call force_fine(ilevel,icount)
   end do

   ! Compute potential at levelmin
   call multigrid_coarse(levelmin,icount)

end subroutine full_multigrid
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine multigrid_coarse(ilevel,icount)
  use hydro_commons
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif
  integer::ilevel,icount
  !--------------------------------------------------------
  ! Multigrid Poisson solver using Gauss-Seidel smoother
  ! with Red-Black ordering.
  !--------------------------------------------------------
  integer::i,idim,info,ind,iter,iterj,itermax,niter_jacobi,iskip,ibound,nx_loc
  logical::multigrid=.true.,redstep=.true.,blackstep=.false.
  real(kind=8)::dx2,oneoversix,fourpi,scale,fact,error_ini,floor,tms
  real(kind=8)::error,rhs_norm,error_all,rhs_norm_all,prec

  if(numbtot(1,ilevel)==0)return
  if(verbose)write(*,111)ilevel

  ! Set local constants
  dx2=(0.5d0**ilevel)**2
  oneoversix=1.0D0/dble(twondim)
  niter_jacobi=2

  !-----------------------------------------------------------
  ! Interpolate potential from coarse to fine as a first guess
  ! and initialize array f(:,1:ndim) to zero
  !-----------------------------------------------------------
  call make_initial_phi(ilevel,icount)

  ! Divide by 4PI
  nx_loc=icoarse_max-icoarse_min+1
  scale=boxlen/dble(nx_loc)
  fourpi=4.D0*ACOS(-1.0D0)*scale
  if(cosmo)fourpi=1.5D0*omega_m*aexp*scale
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        phi(active(ilevel)%igrid(i)+iskip)=phi(active(ilevel)%igrid(i)+iskip)/fourpi
     end do
  end do
  ! Update boundaries for phi
  call make_virtual_fine_dp(phi(1),ilevel)
  ! Update physical boundaries for phi
  do ibound=1,nboundary
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,boundary(ibound,ilevel)%ngrid
           phi(boundary(ibound,ilevel)%igrid(i)+iskip)=0d0
        end do
     end do
  end do

  ! Substract rho_tot to rho
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        rho(active(ilevel)%igrid(i)+iskip)=rho(active(ilevel)%igrid(i)+iskip)-rho_tot
     end do
  end do

  !-----------------------------
  ! Compute right-hand side norm
  !-----------------------------
  rhs_norm=0.0d0; rhs_norm_all=0.0d0
  fact=(oneoversix*dx2)**2/dble(twotondim*numbtot(1,ilevel))
#ifndef NPRE
  prec=1d-10
#else
#if NPRE==4
  prec=1d-4
#else
  prec=1d-10
#endif
#endif
  floor=prec*sqrt(fact*dble(twotondim*numbtot(1,ilevel)))*rho_tot
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        rhs_norm=rhs_norm+fact*rho(active(ilevel)%igrid(i)+iskip)*rho(active(ilevel)%igrid(i)+iskip)
     end do
  end do
  ! Compute global norms
#ifndef WITHOUTMPI
  call MPI_ALLREDUCE(rhs_norm,rhs_norm_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,info)
  rhs_norm=rhs_norm_all
#endif
  rhs_norm=SQRT(rhs_norm)

  !-------------------------------
  ! Upward Gauss-Seidel iterations
  !-------------------------------
  do iterj=1,niter_jacobi
     call gauss_seidel(ilevel,redstep)
     call make_virtual_fine_dp(phi(1),ilevel)
     call gauss_seidel(ilevel,blackstep)
     call make_virtual_fine_dp(phi(1),ilevel)
  end do

  !------------------------------------------
  ! Compute residual and store it in f(i,1)
  !------------------------------------------
  call cmp_residual_mg(ilevel)

  !----------------------------------------
  ! Compute residual norm
  !----------------------------------------
  error=0.0d0; error_all=0.0d0
  fact=(oneoversix*dx2)**2/dble(twotondim*numbtot(1,ilevel))
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        error=error+fact*f(active(ilevel)%igrid(i)+iskip,1)*f(active(ilevel)%igrid(i)+iskip,1)
     end do
  end do
  ! Compute global norms
#ifndef WITHOUTMPI
  call MPI_ALLREDUCE(error,error_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,info)
  error=error_all
#endif
  error=SQRT(error)

  !--------------------
  ! Main iteration loop
  !--------------------
  error_ini=error
  iter=0; itermax=100
  if(debug.and.myid==1)then
     write(*,*)'rhs_norm =',rhs_norm
     write(*,*)'error_ini=',error_ini
     write(*,*)'floor=    ',floor
  endif
  do while(error>epsilon*(error_ini+floor).and.iter<itermax)
  iter=iter+1

  !--------------------------------------
  ! Get correction from upper level solve
  !--------------------------------------
  if(ilevel>1)then
     call restriction_fine(ilevel-1,multigrid)    ! Apply restriction operator
     call multigrid_iterator(ilevel-1)           ! Recursive call to multigrid
     call prolong(ilevel)! Correct current potential with prolongated solution
     call make_virtual_fine_dp(phi(1),ilevel)      ! Update boundaries for phi
  end if

  !---------------------------------
  ! Downward Gauss-Seidel iterations
  !---------------------------------
  do iterj=1,niter_jacobi
     call gauss_seidel(ilevel,redstep)
     call make_virtual_fine_dp(phi(1),ilevel)
     call gauss_seidel(ilevel,blackstep)
     call make_virtual_fine_dp(phi(1),ilevel)
  end do

  !------------------------------------------
  ! Compute residual and store it in f(i,1)
  !------------------------------------------
  call cmp_residual_mg(ilevel)

  !----------------------------------------
  ! Compute residual norm
  !----------------------------------------
  error=0.0d0; error_all=0.0d0
  fact=(oneoversix*dx2)**2/dble(twotondim*numbtot(1,ilevel))
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        error=error+fact*f(active(ilevel)%igrid(i)+iskip,1)*f(active(ilevel)%igrid(i)+iskip,1)
     end do
  end do
  ! Compute global norms
#ifndef WITHOUTMPI
  call MPI_ALLREDUCE(error,error_all,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,info)
  error=error_all
#endif
  error=SQRT(error)

  if(verbose)write(*,112)iter,error/(rhs_norm+floor),error/(error_ini+floor)
  if(debug.and.myid==1)write(*,112)iter,error/(rhs_norm+floor),error/(error_ini+floor)
  end do
  !---------------------------
  ! End main iteration loop
  !---------------------------
  if(myid==1)write(*,115)ilevel,iter,error/(rhs_norm+floor),error/(error_ini+floor)
  if(iter>=itermax)then
     if(myid==1)write(*,*)'Poisson failed to converge...'
  end if

  ! Multiply by 4PI
  nx_loc=icoarse_max-icoarse_min+1
  scale=boxlen/dble(nx_loc)
  fourpi=4.D0*ACOS(-1.0D0)*scale
  if(cosmo)fourpi=1.5D0*omega_m*aexp*scale
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        phi(active(ilevel)%igrid(i)+iskip)=phi(active(ilevel)%igrid(i)+iskip)*fourpi
     end do
  end do
  ! Update boundaries for phi
  call make_virtual_fine_dp(phi(1),ilevel)
  ! Update physical boundaries for phi
  do ibound=1,nboundary
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,boundary(ibound,ilevel)%ngrid
           phi(boundary(ibound,ilevel)%igrid(i)+iskip)=0d0
        end do
     end do
  end do
  ! Add rho_tot to rho
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        rho(active(ilevel)%igrid(i)+iskip)=rho(active(ilevel)%igrid(i)+iskip)+rho_tot
     end do
  end do

111 format('   Entering multigrid_coarse for level ',I2)
112 format('   ==> Step=',i5,' Error=',2(1pe10.3,1x))
115 format('   ==> Level=',i5,' Step=',i5,' Error=',2(1pe10.3,1x))

end subroutine multigrid_coarse
!###########################################################
!###########################################################
!###########################################################
!###########################################################
recursive subroutine multigrid_iterator(ilevel)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  integer::ilevel
  !--------------------------------------------------------
  ! Multigrid Poisson solver using Gauss-Seidel smoother
  ! with Red-Black ordering
  !--------------------------------------------------------
  integer::i,ind,iter,niter_jacobi,iskip
  logical::multigrid=.true.,redstep=.true.,blackstep=.false.
  real(kind=8)::dx2,oneoversix,fact,tms

  if(numbtot(1,ilevel)==0)return

  ! Set local constants
  dx2=(0.5d0**ilevel)**2
  oneoversix=1.0D0/dble(twondim)
  niter_jacobi=3

  !---------------------------------------------
  ! Compute first guess as the diagonal solution
  !---------------------------------------------
  fact=oneoversix*dx2
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        phi(active(ilevel)%igrid(i)+iskip)=-fact*rho(active(ilevel)%igrid(i)+iskip)
     end do
  end do
  ! Update boundaries for phi
  call make_virtual_fine_dp(phi(1),ilevel)

  !-------------------------------
  ! Upward Gauss-Seidel iterations
  !-------------------------------
  do iter=1,niter_jacobi
     call gauss_seidel(ilevel,redstep)
     call make_virtual_fine_dp(phi(1),ilevel)
     call gauss_seidel(ilevel,blackstep)
     call make_virtual_fine_dp(phi(1),ilevel)
  end do

  !------------------------------------------
  ! Compute residual and store it in f(i,1)
  !------------------------------------------
  call cmp_residual_mg(ilevel)

  !--------------------------------------
  ! Get correction from upper level solve
  !--------------------------------------
  if(ilevel>1)then
     call restriction_fine(ilevel-1,multigrid)    ! Apply restriction operator
     call multigrid_iterator(ilevel-1)           ! Recursive call to multigrid
     call prolong(ilevel)! Correct current potential with prolongated solution
     call make_virtual_fine_dp(phi(1),ilevel)      ! Update boundaries for phi
  end if

  !---------------------------------
  ! Downward Gauss-Seidel iterations
  !---------------------------------
  do iter=1,niter_jacobi
     call gauss_seidel(ilevel,redstep)
     call make_virtual_fine_dp(phi(1),ilevel)
     call gauss_seidel(ilevel,blackstep)
     call make_virtual_fine_dp(phi(1),ilevel)
  end do

end subroutine multigrid_iterator
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine gauss_seidel(ilevel,redstep)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  integer::ilevel
  logical::redstep
  !------------------------------------------------------------------
  ! This routine computes one relaxation sweep
  ! for one Gauss-Seidel iteration.
  !------------------------------------------------------------------
  integer::i,ind0,idim,igrid,ngrid,ncache,ind,iskip
  integer::id1,id2,ig1,ig2,ih1,ih2
  real(kind=8)::oneoversix,dx,dx2
  integer,dimension(1:3,1:4)::ired,iblack
  integer,dimension(1:3,1:2,1:8)::iii,jjj

  integer,dimension(1:nvector),save::ind_grid,ind_cell
  integer,dimension(1:nvector,0:twondim),save::igridn
  real(dp),dimension(1:nvector,1:ndim),save::phig,phid
  real(dp),dimension(1:nvector),save::residu

  ! Set constants
  dx=0.5d0**ilevel
  dx2=dx*dx
  oneoversix=1.0D0/dble(twondim)

  ired  (1,1:4)=(/1,0,0,0/)
  iblack(1,1:4)=(/2,0,0,0/)
  ired  (2,1:4)=(/1,4,0,0/)
  iblack(2,1:4)=(/2,3,0,0/)
  ired  (3,1:4)=(/1,4,6,7/)
  iblack(3,1:4)=(/2,3,5,8/)
  iii(1,1,1:8)=(/1,0,1,0,1,0,1,0/); jjj(1,1,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(1,2,1:8)=(/0,2,0,2,0,2,0,2/); jjj(1,2,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(2,1,1:8)=(/3,3,0,0,3,3,0,0/); jjj(2,1,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(2,2,1:8)=(/0,0,4,4,0,0,4,4/); jjj(2,2,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(3,1,1:8)=(/5,5,5,5,0,0,0,0/); jjj(3,1,1:8)=(/5,6,7,8,1,2,3,4/)
  iii(3,2,1:8)=(/0,0,0,0,6,6,6,6/); jjj(3,2,1:8)=(/5,6,7,8,1,2,3,4/)

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector

     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Gather neighboring grids
     do i=1,ngrid
        igridn(i,0)=ind_grid(i)
     end do
     do idim=1,ndim
        do i=1,ngrid
           igridn(i,2*idim-1)=son(nbor(ind_grid(i),2*idim-1))
           igridn(i,2*idim  )=son(nbor(ind_grid(i),2*idim  ))
        end do
     end do

     ! Loop over red or black cells
     do ind0=1,twotondim/2
        if(redstep)then
           ind=ired  (ndim,ind0)
        else
           ind=iblack(ndim,ind0)
        end if

        do idim=1,ndim
           id1=jjj(idim,1,ind); ig1=iii(idim,1,ind)
           ih1=ncoarse+(id1-1)*ngridmax
           do i=1,ngrid
              phig(i,idim)=phi(igridn(i,ig1)+ih1)
           end do
           id2=jjj(idim,2,ind); ig2=iii(idim,2,ind)
           ih2=ncoarse+(id2-1)*ngridmax
           do i=1,ngrid
              phid(i,idim)=phi(igridn(i,ig2)+ih2)
           end do
        end do

        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do

        ! Compute new potential using old neighbors potential
        do i=1,ngrid
           residu(i)=0.0d0
        end do
        do idim=1,ndim
           do i=1,ngrid
              residu(i)=residu(i)+oneoversix*(phig(i,idim)+phid(i,idim))
           end do
        end do
        do i=1,ngrid
           residu(i)=residu(i)-oneoversix*dx2*rho(ind_cell(i))
        end do
        do i=1,ngrid
           phi(ind_cell(i))=residu(i)
        end do

     end do
     ! Loop over cells

  end do
  ! Loop over grids

end subroutine gauss_seidel
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine cmp_residual_mg(ilevel)
  use amr_commons
  use pm_commons
  use poisson_commons
  implicit none
  integer::ilevel
  !------------------------------------------------------------------
  ! This routine computes the residual r = b - A x
  ! and stores it in f(i,1)
  !------------------------------------------------------------------
  integer::i,idim,igrid,ngrid,ncache,ind,iskip
  integer::id1,id2,ig1,ig2,ih1,ih2
  real(kind=8)::oneoversix,dx,dx2
  integer,dimension(1:3,1:2,1:8)::iii,jjj

  integer ,dimension(1:nvector),save::ind_grid,ind_cell
  integer ,dimension(1:nvector,0:twondim),save::igridn
  real(dp),dimension(1:nvector,1:ndim),save::phig,phid
  real(kind=8),dimension(1:nvector),save::residu

  ! Set constants
  dx=0.5d0**ilevel
  dx2=dx*dx
  oneoversix=1.0D0/dble(twondim)

  iii(1,1,1:8)=(/1,0,1,0,1,0,1,0/); jjj(1,1,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(1,2,1:8)=(/0,2,0,2,0,2,0,2/); jjj(1,2,1:8)=(/2,1,4,3,6,5,8,7/)
  iii(2,1,1:8)=(/3,3,0,0,3,3,0,0/); jjj(2,1,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(2,2,1:8)=(/0,0,4,4,0,0,4,4/); jjj(2,2,1:8)=(/3,4,1,2,7,8,5,6/)
  iii(3,1,1:8)=(/5,5,5,5,0,0,0,0/); jjj(3,1,1:8)=(/5,6,7,8,1,2,3,4/)
  iii(3,2,1:8)=(/0,0,0,0,6,6,6,6/); jjj(3,2,1:8)=(/5,6,7,8,1,2,3,4/)

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector

     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Gather neighboring grids
     do i=1,ngrid
        igridn(i,0)=ind_grid(i)
     end do
     do idim=1,ndim
        do i=1,ngrid
           igridn(i,2*idim-1)=son(nbor(ind_grid(i),2*idim-1))
           igridn(i,2*idim  )=son(nbor(ind_grid(i),2*idim  ))
        end do
     end do

     ! Loop over cells
     do ind=1,twotondim
        do idim=1,ndim
           id1=jjj(idim,1,ind); ig1=iii(idim,1,ind)
           ih1=ncoarse+(id1-1)*ngridmax
           do i=1,ngrid
              phig(i,idim)=phi(igridn(i,ig1)+ih1)
           end do
           id2=jjj(idim,2,ind); ig2=iii(idim,2,ind)
           ih2=ncoarse+(id2-1)*ngridmax
           do i=1,ngrid
              phid(i,idim)=phi(igridn(i,ig2)+ih2)
           end do
        end do
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do
        ! Compute residual
        do i=1,ngrid
           residu(i)=phi(ind_cell(i))
        end do
        do idim=1,ndim
           do i=1,ngrid
              residu(i)=residu(i)-oneoversix*(phig(i,idim)+phid(i,idim))
           end do
        end do
        do i=1,ngrid
           residu(i)=residu(i)+oneoversix*dx2*rho(ind_cell(i))
        end do
        do i=1,ngrid
           f(ind_cell(i),1)=residu(i)/oneoversix/dx2
        end do
     end do
     ! End loop over cells

  end do
  ! End loop over grids

end subroutine cmp_residual_mg
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine restriction_fine(ilevel,multigrid)
  use amr_commons
  use hydro_commons
  use poisson_commons
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif
  integer::ilevel
  logical::multigrid
  !-------------------------------------------------------------------
  ! This routine compute array rho (source term for Poisson equation)
  ! by first reseting array rho to zero, then
  ! by affecting the gas density to leaf cells, and finally
  ! by performing a restriction operation for split cells.
  ! For pure particle runs, the restriction is not necessary and the
  ! routine only set rho to zero. On the other hand, for the Multigrid
  ! solver, the restriction is necessary in any case.
  !-------------------------------------------------------------------
  integer ::ind,i,icpu,ncache,igrid,ngrid,iskip,info,ibound,nx_loc
  integer ::idim,nleaf,ix,iy,iz
  integer,dimension(1:nvector),save::ind_grid, ind_cell, ind_leaf
  real(dp),dimension(1:nvector,1:ndim),save::xx
  real(dp),dimension(1:nvector),save::dd
  real(kind=8)::vol,dx,dx_loc,scale,vol_loc
  real(dp),dimension(1:3)::skip_loc
  real(dp),dimension(1:twotondim,1:3)::xc

  if(numbtot(1,ilevel)==0)return
  if(verbose)write(*,111)ilevel

  ! Mesh spacing in that level
  dx=0.5D0**ilevel
  nx_loc=(icoarse_max-icoarse_min+1)
  scale=boxlen/dble(nx_loc)
  dx_loc=dx*scale
  vol_loc=dx_loc**ndim

  ! Initialize density field to zero
  do icpu=1,ncpu
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,reception(icpu,ilevel)%ngrid
           rho(reception(icpu,ilevel)%igrid(i)+iskip)=0.0D0
        end do
     end do
  end do
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,active(ilevel)%ngrid
        rho(active(ilevel)%igrid(i)+iskip)=0.0D0
     end do
  end do
  do ibound=1,nboundary
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,boundary(ibound,ilevel)%ngrid
           rho(boundary(ibound,ilevel)%igrid(i)+iskip)=0.0D0
        end do
     end do
  end do

  ! Perform a restriction over split cells (ilevel+1)
  if(ilevel<nlevelmax)then
     ncache=active(ilevel+1)%ngrid
     do igrid=1,ncache,nvector
        ! Gather nvector grids
        ngrid=MIN(nvector,ncache-igrid+1)
        do i=1,ngrid
           ind_grid(i)=active(ilevel+1)%igrid(igrid+i-1)
        end do
        call restrict(ind_grid,ngrid,ilevel+1,multigrid)
     end do
  end if
  ! Update boundaries
  call make_virtual_reverse_dp(rho(1),ilevel)
  call make_virtual_fine_dp   (rho(1),ilevel)

111 format('   Entering restriction_fine for level',i2)

end subroutine restriction_fine
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine restrict(ind_grid,ngrid,ilevel,multigrid)
  use amr_commons
  use poisson_commons
  implicit none
  integer::ngrid,ilevel
  logical::multigrid
  integer,dimension(1:nvector)::ind_grid
  !
  !
  integer ,dimension(1:nvector),save::ind_cell,ind_cell_father
  integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells
  integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids
  real(dp),dimension(1:nvector),save::new_rho

  real(dp)::a,b,c,d,coeff
  real(dp),dimension(1:8)::bbb
  integer ,dimension(1:8,1:8)::ccc

  integer::i,ind_father,ind_average,ind,iskip

  a = 1.0D0/4.0D0**ndim
  b = 3.0D0*a
  c = 9.0D0*a
  d = 27.D0*a

  bbb(:)  =(/a ,b ,b ,c ,b ,c ,c ,d/)
  bbb=bbb/dble(twotondim)

  ccc(:,1)=(/1 ,2 ,4 ,5 ,10,11,13,14/)
  ccc(:,2)=(/3 ,2 ,6 ,5 ,12,11,15,14/)
  ccc(:,3)=(/7 ,8 ,4 ,5 ,16,17,13,14/)
  ccc(:,4)=(/9 ,8 ,6 ,5 ,18,17,15,14/)
  ccc(:,5)=(/19,20,22,23,10,11,13,14/)
  ccc(:,6)=(/21,20,24,23,12,11,15,14/)
  ccc(:,7)=(/25,26,22,23,16,17,13,14/)
  ccc(:,8)=(/27,26,24,23,18,17,15,14/)

  ! Compute father cell index
  do i=1,ngrid
     ind_cell(i)=father(ind_grid(i))
  end do

  ! Gather 3x3x3 neighboring parent cells
  call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ngrid,ilevel)

  ! Update residual for coarse grid cells
  do ind=1,twotondim
     iskip=ncoarse+(ind-1)*ngridmax
     do i=1,ngrid
        ind_cell(i)=iskip+ind_grid(i)
     end do
     ! Loop over relevant parent cells
     do ind_average=1,twotondim
        ind_father=ccc(ind_average,ind)
        coeff     =bbb(ind_average)
        do i=1,ngrid
           ind_cell_father(i)=nbors_father_cells(i,ind_father)
        end do
        ! Gather rho in temporary array
        do i=1,ngrid
           new_rho(i)=rho(ind_cell_father(i))
        end do
        ! Perform CIC projection
        if(multigrid)then
           do i=1,ngrid
              new_rho(i)=new_rho(i)+coeff*f(ind_cell(i),1)
           end do
        else
           do i=1,ngrid
              new_rho(i)=new_rho(i)+coeff*rho(ind_cell(i))
           end do
        end if
        ! Update array rho
        do i=1,ngrid
           rho(ind_cell_father(i))=new_rho(i)
        end do

     end do
  end do

end subroutine restrict
!###########################################################
!###########################################################
!###########################################################
!###########################################################
subroutine prolong(ilevel)
  use amr_commons
  use poisson_commons
  implicit none
  integer::ilevel
  ! This routine updates the current solution using the correction
  ! given by the prolongated solution at the finer level.
  integer::i,ind_father,ind_average,ind,iskip,ncache,igrid,ngrid

  real(dp)::a,b,c,d,coeff
  real(dp),dimension(1:8)::bbb
  integer,dimension(1:8,1:8)::ccc

  integer ,dimension(1:nvector),save::ind_grid,ind_cell
  integer ,dimension(1:nvector,1:threetondim),save::nbors_father_cells
  integer ,dimension(1:nvector,1:twotondim),save::nbors_father_grids
  real(dp),dimension(1:nvector),save::new_rho

  ! Local constants
  a = 1.0D0/4.0D0**ndim
  b = 3.0D0*a
  c = 9.0D0*a
  d = 27.D0*a

  bbb(:)  =(/a ,b ,b ,c ,b ,c ,c ,d/)

  ccc(:,1)=(/1 ,2 ,4 ,5 ,10,11,13,14/)
  ccc(:,2)=(/3 ,2 ,6 ,5 ,12,11,15,14/)
  ccc(:,3)=(/7 ,8 ,4 ,5 ,16,17,13,14/)
  ccc(:,4)=(/9 ,8 ,6 ,5 ,18,17,15,14/)
  ccc(:,5)=(/19,20,22,23,10,11,13,14/)
  ccc(:,6)=(/21,20,24,23,12,11,15,14/)
  ccc(:,7)=(/25,26,22,23,16,17,13,14/)
  ccc(:,8)=(/27,26,24,23,18,17,15,14/)

  ! Loop over myid grids by vector sweeps
  ncache=active(ilevel)%ngrid
  do igrid=1,ncache,nvector

     ! Gather nvector grids
     ngrid=MIN(nvector,ncache-igrid+1)
     do i=1,ngrid
        ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
     end do

     ! Compute father cell index
     do i=1,ngrid
        ind_cell(i)=father(ind_grid(i))
     end do

     ! Gather 3x3x3 neighboring parent cells
     call get3cubefather(ind_cell,nbors_father_cells,nbors_father_grids,ngrid,ilevel)

     ! Update solution for fine grid cells
     do ind=1,twotondim
        iskip=ncoarse+(ind-1)*ngridmax
        do i=1,ngrid
           ind_cell(i)=iskip+ind_grid(i)
        end do
        new_rho=0.0d0

        ! Loop over relevant parent cells
        do ind_average=1,twotondim
           ind_father=ccc(ind_average,ind)
           coeff     =bbb(ind_average)
           do i=1,ngrid
              new_rho(i)=new_rho(i)+coeff*phi(nbors_father_cells(i,ind_father))
           end do
        end do

        ! Correct potential
        do i=1,ngrid
           phi(ind_cell(i))=phi(ind_cell(i))+new_rho(i)
        end do

     end do
     ! End loop over cells

  end do
  ! End loop over grids

end subroutine prolong


SUBROUTINE wave_propogation(num_steps, scale, damping, initial_P, stop_step, P)
  IMPLICIT NONE
  INTEGER size_x,size_Y,i,j,k,step
  REAL PI, omega
  INTEGER, INTENT(in)  :: num_steps, scale, stop_step !input
  REAL, INTENT(in) :: damping, initial_P !input
  REAL, INTENT(out) :: P(2 * scale + 1,2 * scale + 1) ! output
  REAL, DIMENSION(2 * scale + 1,2 * scale + 1,4) :: V

  size_x = 2 * scale + 1
  size_Y = 2 * scale + 1

  PI = 3.14159
  omega = 3.0 / (2.0 * PI)

  DO k=1,4
     DO j=1,size_x
        DO i=1,size_x
           P(i,j) = 0.0
           V(i,j,k) = 0.0
        END DO
     END DO
  END DO

  P(scale,scale) = initial_P

  DO step = 1,num_steps
     IF(step <= stop_step) THEN
        P(scale,scale) = initial_P * SIN(omega * step)
     ENDIF

     DO j=1,size_x
        DO i=1,size_x
           V(i,j,1) = MERGE(V(i,j,1) + P(i,j) - P(i - 1,j), P(i,j), i > 1)
           V(i,j,2) = MERGE(V(i,j,2) + P(i,j) - P(i,j + 1), P(i,j), j < size_x - 1)
           V(i,j,3) = MERGE(V(i,j,3) + P(i,j) - P(i + 1,j), P(i,j), i < size_y - 1)
           V(i,j,4) = MERGE(V(i,j,4) + P(i,j) - P(i,j - 1), P(i,j), j > 1)
        END DO
     END DO

     DO j=1,size_x
        DO i=1,size_x
           P(i,j) = P(i,j) - 0.5 * damping * (V(i,j,1) + V(i,j,2) + V(i,j,3) + V(i,j,4))
        END DO
     END DO
  END DO

END SUBROUTINE wave_propogation


! ==================================================================
subroutine rptt3(ixyz,icoor,imp,impt,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,bsasdq,cmbsasdq,cpbsasdq)
! ==================================================================

!     # Double transverse Riemann solver for the acoustics equations
!     # with varying material properties.

!     # auxN(i,1,:) holds impedance Z
!     # auxN(i,2,:) holds sound speed c
!     #
!     # On input,

!     #    ql,qr is the data along some one-dimensional slice, as in rpn3
!     #         This slice is
!     #             in the x-direction if ixyz=1,
!     #             in the y-direction if ixyz=2, or
!     #             in the z-direction if ixyz=3.

!     #    bsasdq is an array of flux differences that result from a
!     #         transverse splitting (a previous call to rpt3).
!     #         This stands for B^* A^* \Dq but could represent any of
!     #         6 possibilities, e.g.  C^* B^* \Dq, as specified by ixyz
!     #         and icoor (see below).
!     #         Moreover, each * represents either + or -, as specified by
!     #         imp and impt.

!     #    ixyz indicates the direction of the original Riemann solve,
!     #         called the x-like direction in the table below:

!     #               x-like direction   y-like direction   z-like direction
!     #      ixyz=1:        x                  y                  z
!     #      ixyz=2:        y                  z                  x
!     #      ixyz=3:        z                  x                  y

!     #    icoor indicates direction in which the transverse solve should
!     #         be performed.
!     #      icoor=2: split in the y-like direction.
!     #      icoor=3: split in the z-like direction.

!     #    For example,
!     #        ixyz=1, icoor=3 means bsasdq=B^*A^*\Dq, and should be
!     #                        split in z into
!     #                           cmbsasdq = C^-B^*A^*\Dq,
!     #                           cpbsasdq = C^+B^*A^*\Dq.
!     #
!     #        ixyz=2, icoor=3 means bsasdq=C^*B^*\Dq, and should be
!     #                        split in x into
!     #                           cmbsasdq = A^-C^*B^*\Dq,
!     #                           cpbsasdq = A^+C^*B^*\Dq.

!     #    The parameters imp and impt are generally needed only if aux
!     #    arrays are being used, in order to access the appropriate
!     #    variable coefficients:

!     #    imp =  1 if bsasdq = B^*A^- \Dq, a left-going flux difference
!     #           2 if bsasdq = B^*A^+ \Dq, a right-going flux difference
!     #    impt = 1 if bsasdq = B^-A^* \Dq, a down-going flux difference
!     #           2 if bsasdq = B^+A^* \Dq, an up-going flux difference

!     #    aux2(:,:,2) is a 1d slice of the aux array along the row
!     #                 where the data ql, qr lie.
!     #    aux1(:,:,2) and aux3(:,:,2) are neighboring rows in the
!     #                 y-like direction
!     #    aux2(:,:,1) and aux2(:,:,3) are neighboring rows in the
!     #                z-like direction

    implicit real*8(a-h,o-z)
    dimension       ql(meqn,1-mbc:maxm+mbc)
    dimension       qr(meqn,1-mbc:maxm+mbc)
    dimension   bsasdq(meqn,1-mbc:maxm+mbc)
    dimension cmbsasdq(meqn,1-mbc:maxm+mbc)
    dimension cpbsasdq(meqn,1-mbc:maxm+mbc)
    dimension     aux1(maux,1-mbc:maxm+mbc,3)
    dimension     aux2(maux,1-mbc:maxm+mbc,3)
    dimension     aux3(maux,1-mbc:maxm+mbc,3)

!     # set iuvw = 2,3,4, depending on which component of q represents
!     # velocity in the transverse direction in which splitting is to
!     # be performed:
    iuvw = ixyz + icoor
    if (iuvw > 4) iuvw = iuvw-3

    do 10 i=2-mbc,mx+mbc

    !        # The flux difference bsasdq is split into downward moving part
    !        # traveling at speed -c relative to the medium below and
    !        # an upward moving part traveling at speed +c relative to
    !        # the medium above, in the double-transverse direction specified
    !        # by icoor.

    !        # Note that the sum of these parts does not give all of bsasdq
    !        # since there is also reflection at the interfaces which decreases
    !        # the flux.

    !        # set impendance and sound speed in each row of cells,
    !        # by selecting appropriate values from aux arrays depending on
    !        # values of icoor, imp, impt:

        i1 = i-2+imp    !#  =  i-1 for amdq,  i for apdq

        if (impt == 1) then
        !           # bsasdq propagates to "left" in transverse direction used in rpt3
        !           # so we either use auxN(:,:,1) or aux1(:,:,N) for N=1,2,3
        !           # depending on icoor:

            if (icoor == 2) then
            !           # new double-transverse direction is y-like direction
                zm = aux1(1,i1,1)
                zz = aux2(1,i1,1)
                zp = aux3(1,i1,1)
                cm = aux1(2,i1,1)
                c =  aux2(2,i1,1)
                cp = aux3(2,i1,1)
            else !! (icoor .eq. 3)
            !           # new double-transverse direction is z-like direction
                zm = aux1(1,i1,1)
                zz = aux1(1,i1,2)
                zp = aux1(1,i1,3)
                cm = aux1(2,i1,1)
                c =  aux1(2,i1,2)
                cp = aux1(2,i1,3)
            endif
        else
        !           # bsasdq propagates to "right" in transverse direction used in rpt3
        !           # so we either use auxN(:,:,3) or aux3(:,:,N) for N=1,2,3
        !           # depending on icoor:
            if (icoor == 2) then
            !           # new double-transverse direction is y-like direction
                zm = aux1(1,i1,3)
                zz = aux2(1,i1,3)
                zp = aux3(1,i1,3)
                cm = aux1(2,i1,3)
                c =  aux2(2,i1,3)
                cp = aux3(2,i1,3)
            else !! (icoor .eq. 3)
            !           # new double-transverse direction is z-like direction
                zm = aux3(1,i1,1)
                zz = aux3(1,i1,2)
                zp = aux3(1,i1,3)
                cm = aux3(2,i1,1)
                c =  aux3(2,i1,2)
                cp = aux3(2,i1,3)
            endif
        endif

    !        # transmitted part of down-going wave:
        a1 = (-bsasdq(1,i) + bsasdq(iuvw,i)*zz) / &
        (zm + zz)

    !        # transmitted part of up-going wave:
        a2 = (bsasdq(1,i) + bsasdq(iuvw,i)*zz) / &
        (zz + zp)

    !        # The down-going flux difference cmbsasdq is the product  -c * wave

        cmbsasdq(1,i) = cm * a1*zm
        cmbsasdq(2,i) = 0.d0
        cmbsasdq(3,i) = 0.d0
        cmbsasdq(4,i) = 0.d0
        cmbsasdq(iuvw,i) = -cm * a1

    !        # The up-going flux difference cpbsasdq is the product  c * wave

        cpbsasdq(1,i) = cp * a2*zp
        cpbsasdq(2,i) = 0.d0
        cpbsasdq(3,i) = 0.d0
        cpbsasdq(4,i) = 0.d0
        cpbsasdq(iuvw,i) = cp * a2

    10 END DO

    return
    end subroutine rptt3


c
c-----------------------------------------------------------------------
c
      subroutine ddd2 (prosca,ctonb,ctcab,n,nm,depl,aux,jmin,jmax,diag,
     /                alpha,ybar,sbar,izs,rzs,dzs)
c
c----
c
c     calcule le produit h g ou
c         . h est une matrice construite par la formule de bfgs inverse
c           a nm memoires a partir de la matrice diagonale diag
c           dans un espace hilbertien dont le produit scalaire
c           est donne par prosca
c           (cf. J. Nocedal, Math. of Comp. 35/151 (1980) 773-782)
c         . g est un vecteur de dimension n (en general le gradient)
c
c     la matrice diag apparait donc comme un preconditionneur diagonal
c
c     depl = g (en entree), = h g (en sortie)
c
c     la matrice h est memorisee par les vecteurs des tableaux
c     ybar, sbar et les pointeurs jmin, jmax
c
c     alpha(nm) est une zone de travail
c
c     izs(1),rzs(1),dzs(1) sont des zones de travail pour prosca
c
c----
c
c         arguments
c
      integer n,nm,jmin,jmax,izs(1)
      real rzs(1)
      double precision depl(n),diag(n),alpha(nm),ybar(n,nm),sbar(n,nm),
     /    aux(n),dzs(1)
      external prosca,ctonb,ctcab
c
c         variables locales
c
      integer jfin,i,j,jp
      double precision r,ps
c
      jfin=jmax
      if (jfin.lt.jmin) jfin=jmax+nm
c
c         phase de descente
c
      do 100 j=jfin,jmin,-1
          jp=j
          if (jp.gt.nm) jp=jp-nm
          call prosca (n,depl,sbar(1,jp),ps,izs,rzs,dzs)
          r=ps
          alpha(jp)=r
          do 20 i=1,n
              depl(i)=depl(i)-r*ybar(i,jp)
20        continue
100   continue
c
c         preconditionnement
c
      call ctonb (n,depl,aux,izs,rzs,dzs)
      do 150 i=1,n
          aux(i)=aux(i)*diag(i)
150   continue
      call ctcab (n,aux,depl,izs,rzs,dzs)
c
c         remontee
c
      do 200 j=jmin,jfin
          jp=j
          if (jp.gt.nm) jp=jp-nm
          call prosca (n,depl,ybar(1,jp),ps,izs,rzs,dzs)
          r=alpha(jp)-ps
          do 120 i=1,n
              depl(i)=depl(i)+r*sbar(i,jp)
120       continue
200   continue
      return
      end