      subroutine espod(x,y,z,epot,idebug,
     &                 p)
c THIS IS REALLY espot
      implicit double precision(a-h,o-z)
      parameter (numatm=2000)
      parameter (numprm=1600)
      parameter (numcex=numprm*3)
      parameter (numtmp=4000)
      logical oeerst
      integer shella,shelln,shellt,shellc,shladf,aos
      common/b/exx(numcex),
     &         c1(numcex),c2(numcex),c3(numprm),c4(numprm),c5(numprm),
     &         shladf(numprm),gx(numprm),gy(numprm),gz(numprm),
     &         jan(numprm),shella(numprm),shelln(numprm),shellt(numprm),
     &         shellc(numprm),aos(numprm),nshell,maxtyp
      common /bounds/ ilow(5,5),iupp(5)
      common /indxe/  jx(35),jy(35),jz(35),ix(20),iy(20),iz(20)
      common /strt/   oeerst
      common /moldat/ natoms, norbs, nelecs,nat(numatm)
      common /pseudo / ipseud,ivale(numatm)
      common /coord / xyz(3,numatm)
      common /orbhlp/ mxorb,iuhf,ispd
      common /extchg/ exchg(3,3),iexchg(3),nexchg
      dimension tt(4),zz(4),pre(45),ca(35),cb(35),
     &          coeffx(192),coeffy(192),coeffz(192)
      dimension h(numtmp),f(numtmp),h2x(9),h2y(9),h2z(9),
     &          h3x(16),h3y(16),h3z(16)
      dimension p(*)
      data jx/1,2,1,1,3,1,1,2,2,1,4,1,1,2,3,3,2,1,1,2,
     &           5,1,1,4,4,2,1,2,1,3,3,1,3,2,2/
      data jy/1,1,2,1,1,3,1,2,1,2,1,4,1,3,2,1,1,2,3,2,
     &           1,5,1,2,1,4,4,1,2,3,1,3,2,3,2/
      data jz/1,1,1,2,1,1,3,1,2,2,1,1,4,1,1,2,3,3,2,2,
     &           1,1,5,1,2,1,2,4,4,1,3,3,2,2,3/
      data ix/0,4,0,0,8,0,0,4,4,0,12,0,0,4,8,8,4,0,0,4/
      data iy/0,0,4,0,0,8,0,4,0,4,0,12,0,8,4,0,0,4,8,4/
      data iz/0,0,0,4,0,0,8,0,4,4,0,0,12,0,0,4,8,8,4,4/
c iupp 1  4  10 20 35
c      s  3p 6d 10f 15g
c 
c ilow 0    1       2        3      4    <- shellt
c---------------------------------------
c 0    1(s) 1 (sp)  1 (spd)  1      1
c 1    1    2 (p)   5       11     21
c 2    1    1       5 (d)   11     21
c 3    1    1       5       11 (f) 21
c 4    1    1       5       11     21 (g)
c---------------------------------------
c ^
c | shellc
c
      data iupp/1,4,10,20,35/
      data ilow/5*1,1,2,5,11,21,1,1,5,11,21,1,1,5,11,21,
     &          1,1,5,11,21/

      if (oeerst) then
         call epint
         call setcon
         oeerst = .false.
      endif

      epot = 0.0d0
      pi = 4.d0*datan(1.d0)
c
c     loop over shell pairs.
c
      do ishell = 1, nshell
        xa = gx(ishell)
        ya = gy(ishell)
        za = gz(ishell)
        ifrst = shella(ishell)
        ilast = ifrst + shelln(ishell) - 1
        itype = shellt(ishell)
        itype1 = itype + 1
        istart = ilow(itype1,shellc(ishell)+1)
        iend = iupp(itype1)
        iendt = iend

        do jshell = 1,ishell
          xb = gx(jshell)
          yb = gy(jshell)
          zb = gz(jshell)
          jfsrt = shella(jshell)
          jlast = jfsrt + shelln(jshell) - 1
          jtype = shellt(jshell)
          jtype1 = jtype + 1
          jstart = ilow(jtype1,shellc(jshell)+1)
          jend = iupp(jtype1)
          ijtyp = itype1 + jtype1 - 1
          ndim = (iend-istart+1)*(jend-jstart+1)
          iminj = iabs(ishell - jshell)
          n = (itype + jtype) / 2 + 1
          xt = xb - xa
          yt = yb - ya
          zt = zb - za
          rsq = xt*xt + yt*yt + zt*zt
          if (ndim.gt.numtmp) 
     &       print*,'WARNING: exceding array limit in espot'
          do ii=1,ndim
             h(ii) = 0.0d0
          end do
          jendt = jend
c
c         loop over primitive gaussians.
c
          do igauss = ifrst, ilast
            ei = exx(igauss)
            call fcij(itype,ifrst,igauss,shladf(ishell),ca)
            do jgauss = jfsrt,jlast
              iend = iendt
              jend = jendt
              ej = exx(jgauss)
              call fcij(jtype,jfsrt,jgauss,shladf(jshell),cb)
              ep = ei + ej
              exptmp = ej*ei*rsq / ep
              if (exptmp.ge.600.0d0) goto 100
              expp = 2.0d0*dexp(-exptmp)
              tx = (ei*xa + ej*xb) / ep
              ty = (ei*ya + ej*yb) / ep
              tz = (ei*za + ej*zb) / ep
              xta = tx - xa
              yta = ty - ya
              zta = tz - za
              xtb = tx - xb
              ytb = ty - yb
              ztb = tz - zb
              call coeffs(coeffx,xta,xtb,itype1,jtype1)
              call coeffs(coeffy,yta,ytb,itype1,jtype1)
              call coeffs(coeffz,zta,ztb,itype1,jtype1)
              if (ndim.gt.numtmp) 
     &           print*,'WARNING: exceding array limit in espot'
              do ii=1,ndim
                  f(ii) = 0.0d0
              end do
              xct = x - tx
              yct = y - ty
              zct = z - tz
              expont = ep * (xct * xct + yct * yct + zct * zct)
              call rys(n,expont,tt,zz)
              epp = 0.5d0 / ep
              call calct(pre,epp,ijtyp)
              do ii = 1, n
                fac1 = (ep + ep)*tt(ii)
                zf = pi * expp * zz(ii) / ep
                call twocen(h2x,xct,1.d0,pre,fac1,ijtyp)
                call twocen(h2y,yct,1.d0,pre,fac1,ijtyp)
                call twocen(h2z,zct,zf,pre,fac1,ijtyp)
                call thrcen(h3x,h2x,coeffx,itype1,jtype1)
                call thrcen(h3y,h2y,coeffy,itype1,jtype1)
                call thrcen(h3z,h2z,coeffz,itype1,jtype1)

                k = 0
                do i = istart, iend
                  do j = jstart, jend
                    k = k + 1
                    if (k.gt.numtmp) 
     &                print*,'WARNING: exceding array limit in espot'
                    f(k) = f(k)-
     &           (h3x(jx(j)+ix(i))*h3y(jy(j)+iy(i))*h3z(jz(j)+iz(i)))
                  end do
                end do
              end do

              k = 0
              do i = istart, iend
                do j = jstart,jend
                  k = k + 1
                  if (k.gt.numtmp) 
     &              print*,'WARNING: exceding array limit in espot'
                  h(k) = h(k) + f(k)*ca(i)*cb(j)
                end do
              end do
              kend = k

100           continue
              end do
            end do

            call purdf(itype,jtype,istart,jstart,iend,jend,h)
c
c Density matrix contribution
c

            ii = 0
            ist = aos(ishell) - 1
            jst = aos(jshell) - 1
            do i = istart,iend
               do j = jstart,jend
                  ii = ii + 1
                  if (iminj.eq.0) then
                     a1or2 = 1.0d0
                     if (i-j.lt.0) then
                        pt = p((ist+i-1)*mxorb + (jst+j))
                     else
                        pt = p((jst+j-1)*mxorb + (ist+i))
                     endif
                  else
                     a1or2 = 2.0d0
                     pt = p((jst+j-1)*mxorb + (ist+i))
                  endif
                  phelp = pt*a1or2
                  epot = epot + phelp*h(ii)
            if (idebug.eq.1) print*,'v(',ist+i,',',jst+j,')=',h(ii)
               end do
            end do

            jend = jendt
            iend = iendt
        end do
      end do

c sum in nuclear contribution

c
      do ii = 1 ,natoms
          xt = xyz(1,ii) - x
          yt = xyz(2,ii) - y
          zt = xyz(3,ii) - z
          rsq = xt*xt + yt*yt + zt*zt
          if (rsq.ge.1.0d-8) then
             if (ipseud.eq.1) then
                epot = epot + dfloat(ivale(ii))*dsqrt(1.0d0 / rsq)
             else
                epot = epot + dfloat(nat(ii))*dsqrt(1.0d0 / rsq)
             endif
          endif
      end do

      if (nexchg.ne.0) then
          do ii=1,nexchg
             xt = exchg(1,ii) - x
             yt = exchg(2,ii) - y
             zt = exchg(3,ii) - z
             rsq = xt*xt + yt*yt + zt*zt
             if (rsq.ge.1.0d-8) then
                if (iexchg(ii).eq.1) then
                   epot = epot + dsqrt(1.0d0 / rsq)
                else
                   epot = epot - dsqrt(1.0d0 / rsq)
                endif
             endif
          end do
      endif

      return
      end

      subroutine purdf(itype,jtype,istart,jstart,iend,jend,h)
c
c only iend and jend are really nescessary to return
c
c iupp 1  4  10 20 35
c      s  3p 6d 10f 15g
c 
c ilow 0    1       2        3      4    <- shellt
c---------------------------------------
c 0    1(s) 1 (sp)  1 (spd)  1      1
c 1    1    2 (p)   5       11     21
c 2    1    1       5 (d)   11     21
c 3    1    1       5       11 (f) 21
c 4    1    1       5       11     21 (g)
c---------------------------------------
c ^
c | shellc
c
c question does h come filled in shell form ?, eg d is really spd
c with start at 5 (instead of 1) (we treat d such but not f?)
c
c xxxx,yyyy,zzzz *1
c xxxy ...       *d7
c xxyy ...       *d5*d7/d3
c xxyz ...       *d5*d7
c
c via fcij ca and cb have these, and therfor h() has them 
c
      implicit double precision (a-h,o-z)
      common /slagau/ ihasd,isgau,ido5d,ido7f,ido9g,ihasg
      common /intcon/ d3,d5,d7,r1,r2,r3,r4,r3ov2,z1,z2,z3,
     &                g1,g2,g3,g4,g5,g6
      logical debug
      dimension h(*),inc(14)
      debug = .false.
c
c     convert  gaussians to pure angular functions.
c     (6D -> 5D, 10F -> 7F, 15G -> 9G)
c

      b1 = 1.0d0/d7
      b2 = d3/(d5*d7)
      b3 = 1.0d0/(d5*d7)

      idim = iend - istart + 1
      jdim = jend - jstart + 1

      if (ido5d.eq.1.and.jtype.eq.2) then
c
c     The row side of the matrix: pure d
c     

         i1 = 5 - jstart + 1

c     when d   shell jstart = 5 , i1 = 1, jend = 10, jdim = 6
c     when spd shell jstart = 1 , i1 = 5, jend = 10, jdim = 10
c     single d shell is stored in H() as:
c
c     d1 d2 d3 d4 d5 d6 NOT s px py pz d1 d2 etc

         do i=1,idim
            dz2 = h(i1+2) - 0.5d0*(h(i1) + h(i1+1))
            dx2y2 = r3ov2*(h(i1) - h(i1+1))
            h(i1  ) = dz2
            h(i1+1) = h(i1+4)
            h(i1+2) = h(i1+5)
            h(i1+4) = h(i1+3)
            h(i1+3) = dx2y2
            i1 = i1 + jdim
         end do

      endif
 
      if (ido7f.eq.1.and.jtype.eq.3) then
c
c     The row side af the matrix: pure f
c     
c     when f  shell jstart = 11 , jend = 20, jdim = 10
c
         i1 = 0
         do i=1,idim
 
            f0  = h(i1+3) - r2*(h(i1+6) + h(i1+9))
            f1p = r4*(z1*h(i1+7) - h(i1+1) - z2*h(i1+4))
            f1m = r4*(z1*h(i1+8) - h(i1+2) - z2*h(i1+5))
            f2p = r3ov2*(h(i1+6) - h(i1+9))
            f2m = h(i1+10)
            f3p = r1*(h(i1+1) - z3*h(i1+4))
            f3m = r1*(z3*h(i1+5) - h(i1+2))
 
            h(i1+1) = f0
            h(i1+2) = f1p
            h(i1+3) = f1m
            h(i1+4) = f2p
            h(i1+5) = f2m
            h(i1+6) = f3p
            h(i1+7) = f3m
 
            i1 = i1 + jdim

         end do
      endif

      if (ido9g.eq.1.and.jtype.eq.4) then
c
c     The row side af the matrix: pure g
c     
c     when g  shell jstart = 21 , jend = 35, jdim = 15
c
         i1 = 0
         do i=1,idim
 
          g0  = 
     &       0.375d0*h(i1+1)  + 0.375d0*  h(i1+2) +           h(i1+3) 
     &     -3.0d0*b2*h(i1+11) - 3.0d0*b2*h(i1+12) + 0.75d0*b2*h(i1+10)

          g1p = 
     &  g1*(4.0d0*b1*h(i1+8)  - 3.0d0*b3*h(i1+14) - 3.0d0*b1* h(i1+5))

          g1m = 
     &  g1*(4.0d0*b1*h(i1+9)  - 3.0d0*b3*h(i1+13) - 3.0d0*b1* h(i1+7))

          g2p = 
     &  g2*(6.0d0*b2*h(i1+11) - 6.0d0*b2*h(i1+12) -           h(i1+1) 
     &    +          h(i1+2))

          g2m = 
     &  g3*(6.0d0*b3*h(i1+15) - b1*      h(i1+4)  - b1*       h(i1+6))

          g3p = 
     &  g4*(   b1*   h(i1+5)  - 3.0d0*b3*h(i1+14))

          g3m = 
     &  g4*(3.0d0*b3*h(i1+13) -  b1*     h(i1+7))
 
          g4p = 
     &  g5*(         h(i1+1)  - 6.0d0*b2*h(i1+10) +           h(i1+2))

          g4m = 
     &  g6*b1*(      h(i1+4)  -          h(i1+6))

            h(i1+1) = g0
            h(i1+2) = g1p
            h(i1+3) = g1m
            h(i1+4) = g2p
            h(i1+5) = g2m
            h(i1+6) = g3p
            h(i1+7) = g3m
            h(i1+8) = g4p
            h(i1+9) = g4m
 
            i1 = i1 + jdim

         end do
      endif
c
c     the row size of the matrix has changed, so get rid of
c     the superflous functions.
c
      if ((ido5d.eq.1.and.jtype.eq.2).or.
     &    (ido7f.eq.1.and.jtype.eq.3).or.
     &    (ido9g.eq.1.and.jtype.eq.4)) then

         if (jtype.eq.2) then
            jendp = 9
         else if (jtype.eq.3) then
c     when f   shell jstart = 11 , jend = 17, jpure = jdim = 7, jend = 17
            jendp = 17
         else if (jtype.eq.4) then
c     when g   shell jstart = 21 , jendp = 29, jpure = jdim = 9, jend = 29
            jendp = 29
         endif
         if (debug) print*,'row.old.new ',itype,jtype,jend,jendp
         jrpure = jendp - jstart + 1
 
         i1 = 0
         i2 = 0
 
         do i=1,idim
            do j=1,jrpure
               h(i2+j) = h(i1+j)
            end do
            i1 = i1 + jdim
            i2 = i2 + jrpure
         end do
         jend = jendp
         jdim = jrpure

      endif
c
c     transformation at row side complete, start of column side
c

      if (ido5d.eq.1.and.itype.eq.2) then
c
c     The column side of the matrix: pure d
c
         i1 = (5-istart)*jdim + 1
         do i=1,5
            inc(i) = i*jdim
         end do
 
         do j=1,jdim
            dz2 = h(i1+inc(2)) - 0.5d0*(h(i1) + h(i1+inc(1)))
            dx2y2 = r3ov2*(h(i1) - h(i1+inc(1)))
            h(i1       ) = dz2
            h(i1+inc(1)) = h(i1+inc(4))
            h(i1+inc(2)) = h(i1+inc(5))
            h(i1+inc(4)) = h(i1+inc(3))
            h(i1+inc(3)) = dx2y2
            i1 = i1 + 1
         end do

      endif
 
      if (ido7f.eq.1.and.itype.eq.3) then
c
c     The column side af the matrix: pure F
c
         i1 = 1
         do i=1,9
            inc(i) = i*jdim
         end do
 
         do j=1,jdim
 
            f0  = h(i1+inc(2)) - r2*(h(i1+inc(5)) + h(i1+inc(8)))
            f1p = r4*(z1*h(i1+inc(6)) - h(i1) - z2*h(i1+inc(3)))
            f1m = r4*(z1*h(i1+inc(7)) - h(i1+inc(1))-z2*h(i1+inc(4)))
            f2p = r3ov2*(h(i1+inc(5)) - h(i1+inc(8)))
            f2m = h(i1+inc(9))
            f3p = r1*(h(i1) - z3*h(i1+inc(3)))
            f3m = r1*(z3*h(i1+inc(4)) - h(i1+inc(1)))
    
            h(i1       ) = f0
            h(i1+inc(1)) = f1p
            h(i1+inc(2)) = f1m
            h(i1+inc(3)) = f2p
            h(i1+inc(4)) = f2m
            h(i1+inc(5)) = f3p
            h(i1+inc(6)) = f3m
    
            i1 = i1 + 1
         end do

      endif
 
      if (ido9g.eq.1.and.itype.eq.4) then
c
c     The column side af the matrix: pure G
c
         i1 = 1
         do i=1,14
            inc(i) = i*jdim
         end do
 
         do j=1,jdim
 
          g0  = 
     &          0.375d0*h(i1)         + 0.375d0*  h(i1+inc(1))  +
     &                  h(i1+inc(2))  - 3.0d0*b2* h(i1+inc(10)) - 
     &         3.0d0*b2*h(i1+inc(11)) + 0.75d0*b2*h(i1+inc(9))

          g1p = 
     &     g1*(4.0d0*b1*h(i1+inc(7))  - 3.0d0*b3* h(i1+inc(13)) - 
     &         3.0d0*b1*h(i1+inc(4)))

          g1m = 
     &     g1*(4.0d0*b1*h(i1+inc(8))  - 3.0d0*b3* h(i1+inc(12)) - 
     &         3.0d0*b1*h(i1+inc(6)))

          g2p = 
     &     g2*(6.0d0*b2*h(i1+inc(10)) - 6.0d0*b2* h(i1+inc(11)) -
     &                  h(i1)         +           h(i1+inc(1)))

          g2m = 
     &     g3*(6.0d0*b3*h(i1+inc(14)) - b1*       h(i1+inc(3))  -
     &               b1*h(i1+inc(5)))

          g3p = 
     &     g4*(b1*      h(i1+inc(4))  - 3.0d0*b3* h(i1+inc(13)))

          g3m = 
     &     g4*(3.0d0*b3*h(i1+inc(12)) - b1*       h(i1+inc(6)))
 
          g4p = 
     &      g5*(        h(i1)         - 6.0d0*b2* h(i1+inc(9))  + 
     &                  h(i1+inc(1)))

          g4m = 
     &      g6*b1*(     h(i1+inc(3))  -           h(i1+inc(5)) )

            h(i1       ) = g0
            h(i1+inc(1)) = g1p
            h(i1+inc(2)) = g1m
            h(i1+inc(3)) = g2p
            h(i1+inc(4)) = g2m
            h(i1+inc(5)) = g3p
            h(i1+inc(6)) = g3m
            h(i1+inc(7)) = g4p
            h(i1+inc(8)) = g4m
 
            i1 = i1 + 1
         end do

      endif
      if ((ido5d.eq.1.and.itype.eq.2) .or.
     &    (ido7f.eq.1.and.itype.eq.3) .or.
     &    (ido9g.eq.1.and.itype.eq.4)) then

         if (debug) print*,'colm.old ',itype,jtype,iend
         if (itype.eq.2) then
            iend = 9
         else if (itype.eq.3) then
            iend = 17
         else if (itype.eq.4) then
            iend = 29
         endif
         if (debug) print*,'colm.new ',itype,jtype,iend

      endif
 
      return
      end

      subroutine setcon
      implicit double precision (a-h,o-z)
      common /intcon/ d3,d5,d7,r1,r2,r3,r4,r3ov2,z1,z2,z3,
     &                g1,g2,g3,g4,g5,g6
      d3 = dsqrt(3.0d0)
      d5 = dsqrt(5.0d0)
      d7 = dsqrt(7.0d0)
      z1 = 4.0d0/d5
      z2 = 1.0d0/d5
      z3 = 3.0d0/d5
      r1 = 0.5d0*dsqrt(5.0d0/2.0d0)
      r2 = 1.5d0/d5
      r3ov2 = 0.5d0*dsqrt(3.0d0)
      r3 = r3ov2
      r4 = 0.5d0*dsqrt(3.0d0/2.0d0)

      g1 = dsqrt(5.0d0/8.0d0)
      g2 = dsqrt(5.0d0/16.0d0)
      g3 = dsqrt(5.0d0/4.0d0)
      g4 = dsqrt(35.0d0/8.0d0)
      g5 = dsqrt(35.0d0/64.0d0)
      g6 = dsqrt(35.0d0/4.0d0)

      return
      end

