      subroutine cart_dens_trans_prod_sph(
     $     l1, x1, y1, z1,
     $     l2, x2, y2, z2, 
     $     a, b, c, work, dinv, ld, dens, ndens)
*
* $Id: cart_trans.F 19707 2010-10-29 17:59:36Z d3y133 $
*
      implicit none
      integer l1, l2            ! The angular momenta
      integer ld                ! Dimension parameter for dinv
      double precision x1, y1, z1, x2, y2, z2, a, b, c
      double precision dinv(((ld+1)*(ld+2)*(ld+3))/6,-ld:ld,0:ld)
      double precision dens(((l1+1)*(l1+2))/2,((l2+1)*(l2+2))/2)
      double precision ndens(*), work(*)
c
c     Combine the function of cart_dens_translate/product/to_sph.
c
c     Given in dens a density multiplying cartesian shells of given
c     angular momentum and centers, 
c
c     d(x,y,z) = sum(i,j,k) sum(p,q,r) dens(i,j,k; p,q,r) * 
c     .               (x-z1)^i(y-y1)^j(z-z1)^k * 
c     .               (x-z2)^p(y-y2)^q(z-z2)^r * 
c
c     (where i+j+k = l1 and p+q+r = l2) return the density in the form
c
c     d(x,y,z) = sum(n=0..l1+l2) sum(l=n,0,-2) sum(m=-l,l) 
c     .               ndens(n,l,m) Xlm(x-a,y-b,z-c) r^(n-l) 
c     
c     (where r is the distance of (x,y,z) from (a,b,c)
c
c     The output order in ndens is as described in cart_dens_to_sph
c
c     Both work and ndens need to be dimensioned
c     (((lmax+1)*(lmax+2)*(lmax+3))/6)**2 where lmax=max(l1,l2).
c     The output data in ndens is of length
c     (((l12+1)*(l12+2)*(l12+3))/6) where l12 = l1 + l2.
c
c     Dinv are the cartesian to spherical transformation coeffs 
c     generated by calling xlm_coeff_inv, and ld>=l1+l2.
c
c     The general case ... code special cases for optimization later.
c
c     This routine ONLY translates the polynomial or angular components
c     ... any rescaling due to the gaussian factors must be done
c     separately.
c
c     The input density in dens is preserved.
c
      call cart_dens_translate(l1, x1, y1, z1, l2, x2, y2, z2,
     $     a, b, c, dens, ndens, work)
      call cart_dens_product(l1,l2,ndens,work)
      call cart_dens_to_sph(l1+l2,work,ndens,dinv,ld)
c
      end
      subroutine cart_dens_translate(
     $     l1, x1, y1, z1, 
     $     l2, x2, y2, z2, 
     $     a, b, c, dens, ndens, work)
      implicit none
      integer l1, l2
      double precision x1, y1, z1, x2, y2, z2, a, b, c
      double precision dens(((l1+1)*(l1+2))/2,((l2+1)*(l2+2))/2)
      double precision ndens(*), work(*)
c
c     Given a block of a density matrix for two cartesian shells
c     of angular momentum l1 and l2, respectively, translate
c     the center of expansion for the polynomials from the separate
c     centers of the shells to the common center (a, b, c).
c
c     Work should be the same size as ndens which is
c     ndens((l1+1)*(l1+2)*(l1+3))/6,((l2+1)*(l2+2)*(l2+3))/6)
c
c     The input density d(ijk,pqr) is defined just for 
c     i+j+k=l1 and p+q+r=l2 in the standard order for a cartesian
c     shell.  The output density of necessity will include all
c     functions with i+j+k<=l1 and p+q+r<=l2.  See cart_poly_translate
c     for the ordering and addressing of these functions.
c
c     The input density is preserved.
c
      integer num1, num2, i1, i2, loff1, loff2
c
      integer itri, ind, loff, i, j, l
c
      itri(i,j)  = ((i*(i-1))/2 + j)
      ind(i,j,l) = itri(l-i+1,l-i-j+1) ! Index of x^i*y^j*z^(l-i-j) in
c     .                                ! cartesian shell of rank l
      loff(l) = ((l*(l+1)*(l+2))/6)
c
c
c     Translate shell 1.  First transpose into work(2,1), then
c     translate 1.
c
      num1 = ((l1+1)*(l1+2))/2
      num2 = ((l2+1)*(l2+2))/2
c
      if (l1 .gt. 0) then
         call dfill(loff(l1+1)*num2,0.0d0,work,1)
         loff1= loff(l1)*num2
         do i1 = 1, num1
            do i2 = 1, num2
               work(i2 + loff1) = dens(i1,i2)
            enddo
            loff1 = loff1 + num2
         enddo
         call cart_poly_translate(l1,num2,work,ndens,a-x1,b-y1,c-z1)
c     
c     Transpose back to work(1,2) and translate shell 2
c     
         num1 = loff(l1+1)
         num2 = ((l2+1)*(l2+2))/2
c     
         call dfill(loff(l1+1)*loff(l2+1),0.0d0,work,1)
         loff2= loff(l2)*num1
         do i2 = 1, num2
            loff1 = 0
            do i1 = 1, num1
               work(i1 + loff2) = ndens(i2 + loff1)
               loff1 = loff1 + num2
            enddo
            loff2 = loff2 + num1
         enddo
      else
         call dfill(loff(l1+1)*loff(l2+1),0.0d0,work,1)
         loff2= loff(l2)*num1
         do i2 = 1, num2
            do i1 = 1, num1
               work(i1 + loff2) = dens(i1, i2)
            enddo
            loff2 = loff2 + num1
         enddo
      endif
c
      if (l2 .gt. 0) then
         call cart_poly_translate(l2,num1,work,ndens,a-x2,b-y2,c-z2)
      else
         call dcopy(loff(l1+1)*loff(l2+1),work,1,ndens,1)
      endif
c
      end
      subroutine cart_poly_translate(lmax,npoly,coeff,ncoeff,a,b,c)
      implicit none
      integer lmax, npoly
      double precision  coeff(npoly,*)
      double precision ncoeff(npoly,*)
      double precision a, b, c
c
c     Given a set of polynomials (m=1,..,npoly) defined as
c
c     Pm = sum(i,j,k) coeff(m,i,j,k) x^i y^j z^k
c
c     recompute the coefficients for the polynomial being
c     expanded about the center (a, b, c)
c
c     Use the standard binomial expansion
c
c     (x-a+a)^i = (x'+a)^i = a^i + i*a^(i-1)*x' + ... + x'^i
c
c     coeff of a^p*x^(i-p) is i!/((i-p)!p!)
c
c     ncoeff returns the result, the input coeffs are DESTROYED
c
c     You should have at all points Pm(x,y,z) = Pmnew(x-a,y-b,z-c)
c
c     Included in coeff are all terms x^i y^j z^k with 0 <= i+j+k <= lmax
c     with all terms for each value of l stored contiguously.  Within 
c     a given l value (i+j+k=l) the offset of x^i y^j z^k is given
c     by ind(i,j,l).  The number of preceeding coefficients for all
c     polynomials up to, but not including, l is loff(l) = l*(l+1)*(l+2)/6.
c
c     So the location of (i,j,k) is loff(l)+ind(i,j,l) where l=i+j+k.
c
c     i j k
c     0 0 0
c     1 0 0, 0 1 0, 0 0 1,
c     2 0 0, 1 1 0, 1 0 1, 0 2 0, 0 1 1, 0 0 2
c     ...
c
      integer i, j, k, l, m, p, nijk, ijk, ijkp
      double precision fac
      integer itri, ind, loff
c
      itri(i,j)  = ((i*(i-1))/2 + j)
      ind(i,j,l) = itri(l-i+1,l-i-j+1) ! Index of x^i*y^j*z^(l-i-j) in
c     .                                ! cartesian shell of rank l
      loff(l) = ((l*(l+1)*(l+2))/6)
c
      nijk = loff(lmax+1)
c
c     First translate x
c
      call dfill(npoly*nijk, 0.0d0, ncoeff, 1)
      do l = 0, lmax
         do i = l, 0, -1
            do j = l-i,0,-1
               k = l-i-j
               ijk = loff(l) + ind(i,j,l)
               fac = 1.0d0
               do p = 0, i
                  if (abs(fac) .gt. 0.0d0) then
                     ijkp = loff(l-p) + ind(i-p,j,l-p)
                     do m = 1, npoly
                        ncoeff(m,ijkp) = ncoeff(m,ijkp) + 
     $                       fac*coeff(m,ijk)
                     enddo
                     fac = fac * a * dble(i-p) / dble(p+1)
                  endif
               enddo
            enddo
         enddo
      enddo
c
c     Then y
c
      call dfill(npoly*nijk, 0.0d0, coeff, 1)
c
      do l = 0, lmax
         do i = l, 0, -1
            do j = l-i,0,-1
               k = l-i-j
               ijk = loff(l) + ind(i,j,l)
               fac = 1.0d0
               do p = 0, j
                  if (abs(fac) .gt. 0.0d0) then
                     ijkp = loff(l-p) + ind(i,j-p,l-p)
                     do m = 1, npoly
                        coeff(m,ijkp) = coeff(m,ijkp) + 
     $                       fac*ncoeff(m,ijk)
                     enddo
                     fac = fac * b * dble(j-p) / dble(p+1)
                  endif
               enddo
            enddo
         enddo
      enddo
c
c     Then z
c
      call dfill(npoly*nijk, 0.0d0, ncoeff, 1)
      do l = 0, lmax
         do i = l, 0, -1
            do j = l-i,0,-1
               k = l-i-j
               ijk = loff(l) + ind(i,j,l)
               fac = 1.0d0
               do p = 0, k
                  if (abs(fac) .gt. 0.0d0) then
                     ijkp = loff(l-p) + ind(i,j,l-p)
                     do m = 1, npoly
                        ncoeff(m,ijkp) = ncoeff(m,ijkp) + 
     $                       fac*coeff(m,ijk)
                     enddo
                     fac = fac * c * dble(k-p) / dble(p+1)
                  endif
               enddo
            enddo
         enddo
      enddo
c
      end
      subroutine cart_dens_product(l1,l2,dens,ndens)
      implicit none
      integer l1, l2
      double precision dens(*), ndens(*)
c
c     Given in dens(ijk,pqr) the coefficients multiplying
c     x^(i+p)y^(j+q)z^(k+r) for i+j+k <= l1 and p+q+r <= l2
c     in the ordering generated by cart_{dens,poly}_translate.
c     Resum everything so that we return in ndens(ijk) the equivalent
c     coefficients for x^i*y^j*z^k for (i+j+k) <= (l1+l2) again
c     in the order described in cart_poly_translate
c
c     The arrays should be dimensioned
c
c     dens(loff(l1+1),loff(l2+1))
c     ndens(loff(l1+l2+1))
c
      integer i, j, l, l1p, l2p, i1, i2, j1, j2, k1, k2, ipt, ipt12
      integer i12, j12, l12, loff12
      integer itri, ind, loff
c
      itri(i,j)  = ((i*(i-1))/2 + j)
      ind(i,j,l) = itri(l-i+1,l-i-j+1) ! Index of x^i*y^j*z^(l-i-j) in
c     .                                ! cartesian shell of rank l
      loff(l) = (((l)*(l+1)*(l+2))/6)
c
      call dfill(loff(l1+l2+1),0.0d0,ndens,1)
c
      ipt = 0
      do l2p = 0, l2
         do i2 = l2p,0,-1
            do j2 = l2p-i2,0,-1
               k2 = l2p-i2-j2
               do l1p = 0, l1
                  l12 = l1p + l2p
                  loff12 = loff(l12)
                  do i1 = l1p,0,-1
                     i12 = i1 + i2
                     do j1 = l1p-i1,0,-1
                        k1 = l1p-i1-j1
                        ipt = ipt + 1
c
                        j12 = j1 + j2
                        ipt12 = loff12 + ind(i12,j12,l12)
                        ndens(ipt12) = ndens(ipt12) + dens(ipt)
c
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
c
      end
      subroutine cart_dens_to_sph(lmax,dens,ndens,dinv,ld)
      implicit none
      integer lmax, ld
      double precision dens(*),ndens(*)
      double precision dinv(((ld+1)*(ld+2)*(ld+3))/6,-ld:ld,0:ld)
#include "errquit.fh"
c
c     Given in dens a set of density matrix coefficients
c     for a cartesian basis of the form resulting from 
c     cart_dens_product, transform these into the real solid
c     spherical harmonic basis returning them in ndens.
c
c     dinv should contain the transformation coeffs resulting
c     from call xlm_coeff_inv(ld, d, dinv) (ld >= lmax)
c
c     The input order of coeffs for x^i y^j z^k in dens is
c
c     do l = 0, lmax
c     .  do i = l,0,-1
c     .     do j = l-i,0,-1
c     .        k = l-i-j
c     .        d(i,j,k)
c
c     the output order of coeffs for r^(n-l)Xlm in ndens is
c
c     do n = 0, lmax
c     .  do l = n,0,-2
c     .     do m = -l,l
c     .        d(n,l,m)
c
c     Both dens and ndens are the same size
c
c     (((lmax+1)*(lmax+2)*(lmax+3))/6)
c
      integer ind, n, nbase, loff, l, m, ijk
      double precision sum
      loff(l) = ((l*(l+1)*(l+2))/6)
c
      if (ld .lt. lmax) call errquit(
     $ 'carttrans: ld lt lmax ',ld+lmax*10000, CALC_ERR)
      ind = 0
      do n = 0, lmax
         nbase = loff(n)
         do l = n,0,-2
            do m = -l, l
               sum = 0.0d0
               do ijk = 1,(n+1)*(n+2)/2
                  sum = sum + dens(ijk+nbase)*dinv(ijk+nbase,m,l)
               enddo
               ind = ind + 1
               ndens(ind) = sum
            enddo
         enddo
         if (ind .ne. loff(n+1)) stop 9997
      enddo
c
      end
      subroutine gaussian_product(
     $     zeta1, x1, y1, z1,
     $     zeta2, x2, y2, z2,
     $      zeta,  a,  b,  c, prefac)
      implicit none
      double precision 
     $     zeta1, x1, y1, z1,
     $     zeta2, x2, y2, z2,
     $      zeta,  a,  b,  c, prefac
c
c     The Gaussian product theorem 
c
c     exp(-zeta1*(r-r1)^2)*exp(-zeta2*(r-r2)^2) = 
c     .   exp(-q*(r1-r2)^2)*exp(-zeta*(r-P)^2)
c
c     where
c
c     q    = (zeta1*zeta2)/(zeta1+zeta2)
c     zeta = (zeta1+zeta2)
c     P    = (zeta1*r1+ zeta2*r2)/(zeta1+zeta2)
c
c     Return zeta, P=(a,b,c), and prefac=exp(-q*(r1-r2)^2)
c
      double precision rzeta, q, dx, dy, dz, r12sq
c
      zeta  = (zeta1+zeta2)
      rzeta = 1.0d0/zeta
      q     = (zeta1*zeta2)*rzeta
      a     = (zeta1*x1 + zeta2*x2)*rzeta
      b     = (zeta1*y1 + zeta2*y2)*rzeta
      c     = (zeta1*z1 + zeta2*z2)*rzeta
      dx    = (x1-x2)
      dy    = (y1-y2)
      dz    = (z1-z2)
      r12sq = dx*dx + dy*dy + dz*dz
      prefac= exp(-q*r12sq)
c
      end
