c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine empole  --  multipole & polarization energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "empole" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability
c
c
      subroutine empole
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'mpole.i'
      include 'polar.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k,m
      integer ii,iz,ix
      integer kk,kz,kx
      integer skip(maxatm)
      real*8 eik,ei,ek,a(3,3)
      real*8 shift,taper,trans
      real*8 f,fi,fik,fgrp
      real*8 xr,yr,zr
      real*8 r,r2,r3,r4,r5,r6,r7
      real*8 rpi(13),rpk(13)
      real*8 indi(3),indk(3)
      logical proceed,iuse,kuse
c
c
c     zero out the atomic multipole interaction energy
c
      em = 0.0d0
      ep = 0.0d0
c
c     zero out the list of atoms to be skipped
c
      do i = 1, n
         skip(i) = 0
      end do
      if (chg12use .lt. 0)  chg12use = 0
      if (chg13use .lt. 0)  chg13use = 0
      if (chg14use .lt. 0)  chg14use = 0
c
c     set the switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each atom
c
      call induce
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole-1
         i = ipole(ii)
         iz = zaxis(ii)
         ix = xaxis(ii)
         iuse = (use(i) .or. use(iz) .or. use(ix))
         do j = 1, n12(i)
            skip(i12(j,i)) = i * chg12use
         end do
         do j = 1, n13(i)
            skip(i13(j,i)) = i * chg13use
         end do
         do j = 1, n14(i)
            skip(i14(j,i)) = i * chg14use
         end do
         do j = 1, maxpole
            rpi(j) = rpole(j,ii)
         end do
         do j = 1, 3
            indi(j) = uind(j,ii)
         end do
         fi = f * rpi(1)
         do kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(kk)
            kx = xaxis(kk)
            kuse = (use(k) .or. use(kz) .or. use(kx))
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. kuse)
            if (proceed)  proceed = (skip(k) .ne. i)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(k) - x(i)
               yr = y(k) - y(i)
               zr = z(k) - z(i)
               if (use_image)  call image (xr,yr,zr,0)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  do j = 1, maxpole
                     rpk(j) = rpole(j,kk)
                  end do
                  do j = 1, 3
                     indk(j) = uind(j,kk)
                  end do
                  fik = fi * rpk(1)
                  r = sqrt(r2)
                  call empik (ii,kk,xr,yr,zr,r,rpi,rpk,
     &                          indi,indk,eik,ei,ek)
c
c     use shifted energy switching if near the cutoff distance
c
                  shift = fik / (0.5d0*(off+cut))
                  eik = eik - shift
                  if (r2 .gt. cut2) then
                     r3 = r2 * r
                     r4 = r2 * r2
                     r5 = r2 * r3
                     r6 = r3 * r3
                     r7 = r3 * r4
                     taper = c5*r5 + c4*r4 + c3*r3
     &                          + c2*r2 + c1*r + c0
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                               + f3*r3 + f2*r2 + f1*r + f0)
                     eik = eik * taper + trans
                     ei = ei * taper
                     ek = ek * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     eik = eik * fgrp
                     ei = ei * fgrp
                     ek = ek * fgrp
                  end if
c
c     increment the overall multipole and polarization energies
c
                  em = em + eik
                  ep = ep + ei + ek
               end if
            end if
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(ii)
         ix = xaxis(ii)
         iuse = (use(i) .or. use(iz) .or. use(ix))
         do j = 1, maxpole
            rpi(j) = rpole(j,ii)
         end do
         do j = 1, 3
            indi(j) = uind(j,ii)
         end do
         fi = f * rpi(1)
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(kk)
            kx = xaxis(kk)
            kuse = (use(k) .or. use(kz) .or. use(kx))
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. kuse)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do m = 1, ncell
                  xr = x(k) - x(i)
                  yr = y(k) - y(i)
                  zr = z(k) - z(i)
                  call image (xr,yr,zr,m)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     do j = 1, maxpole
                        rpk(j) = rpole(j,kk)
                     end do
                     do j = 1, 3
                        indk(j) = uind(j,kk)
                     end do
                     fik = fi * rpk(1)
                     r = sqrt(r2)
                     call empik (ii,kk,xr,yr,zr,r,rpi,rpk,
     &                             indi,indk,eik,ei,ek)
c
c     use shifted energy switching if near the cutoff distance
c
                     shift = fik / (0.5d0*(off+cut))
                     eik = eik - shift
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        r6 = r3 * r3
                        r7 = r3 * r4
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                                  + f3*r3 + f2*r2 + f1*r + f0)
                        eik = eik * taper + trans
                        ei = ei * taper
                        ek = ek * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        eik = eik * fgrp
                        ei = ei * fgrp
                        ek = ek * fgrp
                     end if
c
c     increment the overall multipole and polarization energies
c
                     if (i .eq. k) then 
                        eik = 0.5d0 * eik
                        ei = 0.5d0 * ei
                        ek = 0.5d0 * ek
                     end if
                     em = em + eik
                     ep = ep + ei + ek
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empik  --  multipole & polarization pair energy  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empik" computes the permanent multipole and induced dipole
c     energies between a specified pair of atomic multipole sites
c
c
      subroutine empik (ii,kk,xr,yr,zr,r,rpi,rpk,indi,indk,eik,ei,ek)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'chgpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'units.i'
      integer ii,kk
      real*8 eik,ei,ek
      real*8 factor,damp
      real*8 xr,yr,zr,r
      real*8 rr1,rr2,rr3,rr5,rr7,rr9
      real*8 xx,yy,xyz,xry,yrx,zrx,zry
      real*8 xr5,yr5,xr7,yr7
      real*8 xr9,xyr9,yr9,xr9x7,yr9y7
      real*8 rr53,xr73,yr73
      real*8 t1,t2,t3,t4,t5,t6,t7,t8,t9,t11
      real*8 t12,t13,t14,t15,t17,t18,t21,t22
      real*8 t23,t24,t25,t27,t28,t31,t32
      real*8 i0,i1,i2,i3,i4,i5,i6,i7,i8,i9
      real*8 k0,k1,k2,k3,k4,k5,k6,k7,k8,k9
      real*8 u1,u2,u3,v1,v2,v3
      real*8 i3k3,i4i9,i7i9,k4k9,k7k9,i3k6
      real*8 i3k8,i6k3,i8k3,ik49,ik59,ik69
      real*8 ik79,ik89,ik68,i6k6,i8k8,i9k9
      real*8 i3v3,i6v3,i8v3,k3u3,k6u3,k8u3
      real*8 rpi(13),rpk(13)
      real*8 indi(3),indk(3)
      logical iquad,kquad
c
c
c     zero out multipole and polarization energy components
c
      eik = 0.0d0
      ei = 0.0d0
      ek = 0.0d0
c
c     check for presence of quadrupole components at either site
c
      iquad = (polsiz(ii) .ge. 13)
      kquad = (polsiz(kk) .ge. 13)
c
c     set permanent and induced multipoles for first site
c
      i0 = rpi(1)
      i1 = rpi(2)
      i2 = rpi(3)
      i3 = rpi(4)
      i4 = rpi(5)
      i5 = rpi(6)
      i6 = rpi(7)
      i7 = rpi(9)
      i8 = rpi(10)
      i9 = rpi(13)
      u1 = indi(1)
      u2 = indi(2)
      u3 = indi(3)
c
c     set permanent and induced multipoles for second site
c
      k0 = rpk(1)
      k1 = rpk(2)
      k2 = rpk(3)
      k3 = rpk(4)
      k4 = rpk(5)
      k5 = rpk(6)
      k6 = rpk(7)
      k7 = rpk(9)
      k8 = rpk(10)
      k9 = rpk(13)
      v1 = indk(1)
      v2 = indk(2)
      v3 = indk(3)
c
c     compute the zeroth order T2 matrix element
c
      rr1 = 1.0d0 / r
      t1 = rr1
c
c     compute the first order T2 matrix elements
c
      rr2 = rr1 * rr1
      rr3 = rr1 * rr2
      t2 = -xr * rr3
      t3 = -yr * rr3
      t4 = -zr * rr3
c
c     compute the second order T2 matrix elements
c
      rr5 = 3.0d0 * rr3 * rr2
      xr5 = xr * rr5
      yr5 = yr * rr5
      t5 = -rr3 + xr5*xr
      t6 = xr5 * yr
      t7 = xr5 * zr
      t8 = -rr3 + yr5*yr
      t9 = yr5 * zr
c
c     compute the third order T2 matrix elements
c
      if (iquad .or. kquad) then
         rr7 = 5.0d0 * rr5 * rr2
         xx = xr * xr
         yy = yr * yr
         xyz = xr * yr * zr
         xr7 = xx * rr7
         yr7 = yy * rr7
         rr53 = 3.0d0 * rr5
         t11 = xr * (rr53-xr7)
         t12 = yr * (rr5-xr7)
         t13 = zr * (rr5-xr7)
         t14 = xr * (rr5-yr7)
         t15 = -xyz * rr7
         t17 = yr * (rr53-yr7)
         t18 = zr * (rr5-yr7)
c
c     compute the fourth order T2 matrix elements
c
         rr9 = 7.0d0 * rr7 * rr2
         if (xr .eq. 0.0d0) then
            yrx = 0.0d0
            zrx = 0.0d0
         else
            yrx = yr / xr
            zrx = zr / xr
         end if
         if (yr .eq. 0.0d0) then
            xry = 0.0d0
            zry = 0.0d0
         else
            xry = xr / yr
            zry = zr / yr
         end if
         xr9 = xx * xx * rr9
         xyr9 = xx * yy * rr9
         yr9 = yy * yy * rr9
         xr73 = 3.0d0 * xr7
         yr73 = 3.0d0 * yr7
         xr9x7 = xr9 - xr73
         yr9y7 = yr9 - yr73
         t21 = xr9x7 - xr73 + rr53
         t22 = yrx * xr9x7
         t23 = zrx * xr9x7
         t24 = xyr9 - xr7 - yr7 + rr5
         t25 = zry * (xyr9-yr7)
         t27 = xry * yr9y7
         t28 = zrx * (xyr9-xr7)
         t31 = yr9y7 - yr73 + rr53
         t32 = zry * yr9y7
      end if
c
c     get the M-M, M-D and D-D parts of the multipole energy
c
      i3k3 = i3 * k3
      eik = i0*k0*t1 + (i0*k1-i1*k0)*t2 + (i0*k2-i2*k0)*t3
     &         + (i0*k3-i3*k0)*t4 + (i3k3-i1*k1)*t5 - (i1*k2+i2*k1)*t6
     &         - (i1*k3+i3*k1)*t7 + (i3k3-i2*k2)*t8 - (i2*k3+i3*k2)*t9
c
c     get the M-indD and D-indD parts of the polarization energy
c
      i3v3 = i3 * v3
      k3u3 = k3 * u3
      ei = -k0*(u1*t2+u2*t3+u3*t4) + (k3u3-k1*u1)*t5 - (k1*u2+k2*u1)*t6
     &        - (k3*u1+k1*u3)*t7 + (k3u3-k2*u2)*t8 - (k2*u3+k3*u2)*t9
      ek = i0*(v1*t2+v2*t3+v3*t4) + (i3v3-i1*v1)*t5 - (i1*v2+i2*v1)*t6
     &        - (i3*v1+i1*v3)*t7 + (i3v3-i2*v2)*t8 - (i2*v3+i3*v2)*t9
c
c     get the M-Q, D-Q and Q-Dind energies, if necessary
c
      if (kquad) then
         k4k9 = k4 - k9
         k7k9 = k7 - k9
         i3k6 = 2.0d0 * i3 * k6
         i3k8 = 2.0d0 * i3 * k8
         eik = eik + i0*k4k9*t5 + 2.0d0*i0*k5*t6 + 2.0d0*i0*k6*t7
     &             + i0*k7k9*t8 + 2.0d0*i0*k8*t9 + (i3k6-i1*k4k9)*t11
     &             + (i3k8-i2*k4k9-2.0d0*i1*k5)*t12
     &             - (2.0d0*i1*k6+i3*k4k9)*t13
     &             + (i3k6-i1*k7k9-2.0d0*i2*k5)*t14
     &             - 2.0d0*(i1*k8+i2*k6+i3*k5)*t15
     &             + (i3k8-i2*k7k9)*t17
     &             - (2.0d0*i2*k8+i3*k7k9)*t18
         k6u3 = k6 * u3
         k8u3 = k8 * u3
         ei = ei + (-k4k9*u1+2.d0*k6u3)*t11
     &           + (-k4k9*u2+2.d0*(k8u3-k5*u1))*t12
     &           + (-k4k9*u3-2.d0*k6*u1)*t13
     &           + (-k7k9*u1+2.d0*(k6u3-k5*u2))*t14
     &           - 2.0d0*(k5*u3+k6*u2+k8*u1)*t15
     &           + (-k7k9*u2+2.d0*k8u3)*t17
     &           + (-k7k9*u3-2.d0*k8*u2)*t18
      end if
      if (iquad) then
         i4i9 = i4 - i9
         i7i9 = i7 - i9
         i6k3 = -2.0d0 * i6 * k3
         i8k3 = -2.0d0 * i8 * k3
         eik = eik + i4i9*k0*t5 + 2.0d0*i5*k0*t6 + 2.0d0*i6*k0*t7
     &             + i7i9*k0*t8 + 2.0d0*i8*k0*t9 + (i4i9*k1+i6k3)*t11
     &             + (i8k3+i4i9*k2+2.0d0*i5*k1)*t12
     &             + (2.0d0*i6*k1+i4i9*k3)*t13
     &             + (i6k3+i7i9*k1+2.0d0*i5*k2)*t14
     &             + 2.0d0*(i8*k1+i6*k2+i5*k3)*t15
     &             + (i8k3+i7i9*k2)*t17
     &             + (2.0d0*i8*k2+i7i9*k3)*t18
         i6v3 = i6 * v3
         i8v3 = i8 * v3
         ek = ek + (i4i9*v1-2.d0*i6v3)*t11
     &           + (i4i9*v2+2.d0*(i5*v1-i8v3))*t12
     &           + (i4i9*v3+2.d0*i6*v1)*t13
     &           + (i7i9*v1+2.d0*(i5*v2-i6v3))*t14
     &           + 2.0d0*(i5*v3+i6*v2+i8*v1)*t15
     &           + (i7i9*v2-2.d0*i8v3)*t17
     &           + (i7i9*v3+2.d0*i8*v2)*t18
      end if
c
c     get the Q-Q part of the multipole interaction energy
c
      if (iquad .and. kquad) then
         ik49 = i4*k9 + i9*k4
         ik59 = i5*k9 + i9*k5
         ik69 = i6*k9 + i9*k6
         ik79 = i7*k9 + i9*k7
         ik89 = i8*k9 + i9*k8
         ik68 = 2.0d0 * (i6*k8 + i8*k6)
         i6k6 = i6 * k6
         i8k8 = i8 * k8
         i9k9 = i9 * k9
         eik = eik + (i4*k4-ik49+i9k9-4.0d0*i6k6)*t21
     &             + 2.0d0*(i5*k4+i4*k5-ik68-ik59)*t22
     &             + 2.0d0*(i4*k6+i6*k4-ik69)*t23
     &             + (i4*k7+i7*k4-ik49-ik79+2.0d0*i9k9
     &                  +4.0d0*(i5*k5-i6k6-i8k8))*t24
     &             + 2.0d0*(i4*k8+i8*k4+2.0d0*(i5*k6+i6*k5)-ik89)*t25
     &             + 2.0d0*(i5*k7+i7*k5-ik68-ik59)*t27
     &             + 2.0d0*(i6*k7+i7*k6+2.0d0*(i5*k8+i8*k5)-ik69)*t28
     &             + (i7*k7-ik79+i9k9-4.0d0*i8k8)*t31
     &             + 2.0d0*(i7*k8+i8*k7-ik89)*t32
      end if
c
c     apply exponential damping to the polarization term
c
      damp = pdamp(ii) * pdamp(kk)
      if (damp .ne. 0.0d0) then
         damp = -pgamma * (r/damp)**3
         if (damp .gt. -50.0d0) then
            damp = 1.0d0 - exp(damp)
            ei = ei * damp
            ek = ek * damp
         end if
      end if
c
c     set and apply the energy unit conversion factor
c
      factor = electric / dielec
      eik = factor * eik
      ei = 0.5d0 * factor  * ei
      ek = 0.5d0 * factor  * ek
      return
      end
