c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine empole3  --  mpole/polar energy & analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "empole3" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability,
c     and also partitions the energy among the atoms
c
c
      subroutine empole3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'moment.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)
      real*8 weight,xcenter,ycenter,zcenter
      real*8 totchg,xsum,ysum,zsum
      logical header,huge,proceed,iuse,kuse
c
c
c     zero out multipole and polarization energy and partitioning
c
      nem = 0
      nep = 0
      em = 0.0d0
      ep = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
         aep(i) = 0.0d0
      end do
      header = .true.
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     find the center of mass of the total system
c
      weight = 0.0d0
      xcenter = 0.0d0
      ycenter = 0.0d0
      zcenter = 0.0d0
      do i = 1, n
         weight = weight + mass(i)
         xcenter = xcenter + x(i)*mass(i)
         ycenter = ycenter + y(i)*mass(i)
         zcenter = zcenter + z(i)*mass(i)
      end do
      xcenter = xcenter / weight
      ycenter = ycenter / weight
      zcenter = zcenter / weight
c
c     get net charge and dipole components relative to center of mass
c
      totchg = 0.0d0
      xsum = 0.0d0
      ysum = 0.0d0
      zsum = 0.0d0
      do i = 1, npole
         k = ipole(i)
         totchg = totchg + rpole(1,i)
         xsum = xsum + (x(k)-xcenter)*rpole(1,i)
         ysum = ysum + (y(k)-ycenter)*rpole(1,i)
         zsum = zsum + (z(k)-zcenter)*rpole(1,i)
         xsum = xsum + rpole(2,i) + uind(1,i)
         ysum = ysum + rpole(3,i) + uind(2,i)
         zsum = zsum + rpole(4,i) + uind(3,i)
      end do
      netchg = netchg + totchg
      xdipole = xdipole + debye*xsum
      ydipole = ydipole + debye*ysum
      zdipole = zdipole + debye*zsum
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
                  nem = nem + 1
                  em = em + eik
                  aem(i) = aem(i) + 0.5d0*eik
                  aem(k) = aem(k) + 0.5d0*eik
                  nep = nep + 2
                  ep = ep + ei + ek
                  aep(i) = aep(i) + 0.5d0*(ei+ek)
                  aep(k) = aep(k) + 0.5d0*(ei+ek)
c
c     print a warning if the energy of this interaction is large
c
                  huge = (max(abs(eik),abs(ei),abs(ek)) .gt. 100.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,10)
   10                   format (/,' Individual Multipole and',
     &                             ' Polarization Interactions :',
     &                          //,' Type',11x,'Atom Names',
     &                             9x,'Distance',6x,'Energies',
     &                             ' (MPole, Pol1, Pol2)',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),r,
     &                                eik,ei,ek
   20                format (' M-Pole   ',i5,'-',a3,1x,i5,'-',
     &                          a3,5x,f8.4,3f12.4)
                  end if
               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
                     nem = nem + 1
                     nep = nep + 2
                     if (i .eq. k) then
                        em = em + 0.5d0*eik
                        aem(i) = aem(i) + 0.5d0*eik
                        ep = ep + ei
                        aep(i) = aep(i) + ei
                     else
                        em = em + eik
                        aem(i) = aem(i) + 0.5d0*eik
                        aem(k) = aem(k) + 0.5d0*eik
                        ep = ep + ei + ek
                        aep(i) = aep(i) + 0.5d0*(ei+ek)
                        aep(k) = aep(k) + 0.5d0*(ei+ek)
                     end if
c
c     print a warning if the energy of this interaction is large
c
                     huge = (max(abs(eik),abs(ei),abs(ek)) .gt. 100.0d0)
                     if (debug .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,30)
   30                      format (/,' Individual Multipole and',
     &                                ' Polarization Interactions :',
     &                             //,' Type',11x,'Atom Names',
     &                                9x,'Distance',6x,'Energies',
     &                                ' (MPole, Pol1, Pol2)',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),r,
     &                                   eik,ei,ek
   40                   format (' M-Pole   ',i5,'-',a3,1x,i5,'-',
     &                             a3,' (X) ',f8.4,3f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
