c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole2  --  multipole & polarization Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole2" calculates second derivatives of the multipole
c     and dipole polarization energy for a single atom at a time
c
c
      subroutine empole2 (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'hessn.i'
      integer i,j,k
      real*8 eps,old
      real*8 d0(3,maxatm)
c
c
c     set the stepsize to be used for numerical derivatives
c
      eps = 1.0d-7
c
c     get multipole first derivatives for the base structure
c
      call empole2b (i)
      do k = 1, n
         do j = 1, 3
            d0(j,k) = dem(j,k) + dep(j,k)
         end do
      end do
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      x(i) = x(i) + eps
      call empole2b (i)
      x(i) = old
      do k = 1, n
         do j = 1, 3
            hessx(j,k) = hessx(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      y(i) = y(i) + eps
      call empole2b (i)
      y(i) = old
      do k = 1, n
         do j = 1, 3
            hessy(j,k) = hessy(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      z(i) = z(i) + eps
      call empole2b (i)
      z(i) = old
      do k = 1, n
         do j = 1, 3
            hessz(j,k) = hessz(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole2b  --  mpole & polar Hessian; numerical  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole2b" computes multipole and dipole polarization first
c     derivatives for a single angle with respect to Cartesian
c     coordinates; used to get finite difference second derivatives
c
c     note that since polarization effects are many body, it is not
c     really correct to neglect interactions where "iatom" is not
c     directly involved as a multipole site or local coordinate axis;
c     however, other sites are neglected in this version via the
c     "ipart" and "kpart" checks to quickly get approximate values
c
c
      subroutine empole2b (iatom)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.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 jj,iatom
      integer ii,iz,ix
      integer kk,kz,kx
      integer skip(maxatm)
      real*8 eik,ei,ek,de
      real*8 f,fi,fik,fgrp
      real*8 shift,taper,dtaper
      real*8 trans,dtrans
      real*8 xi,yi,zi,xr,yr,zr
      real*8 r,r2,r3,r4,r5,r6,r7
      real*8 a(3,3),d(3,3,3,3)
      real*8 rpi(13),rpk(13)
      real*8 indi(3),indk(3)
      real*8 dm(3),dp(3),utu
      real*8 dmi(3,3),dmk(3,3)
      real*8 dpi(3,3),dpk(3,3)
      logical proceed,iuse,kuse,ipart,kpart
c
c
c     zero out the multipole and polarization first derivatives
c
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
         end do
      end do
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 multipole components and get rotation derivatives
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
         call drotmat (i,d)
         do j = 1, 3
            do k = 1, 3
               call drotpole (i,a,d,j,k)
            end do
         end do
      end do
c
c     compute the induced dipoles at each atom
c
      call induce
c
c     compute and partition multipole interaction energy
c
      do ii = 1, npole-1
         i = ipole(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(ii)
         ix = xaxis(ii)
         ipart = (i.eq.iatom .or. iz.eq.iatom .or. ix.eq.iatom)
         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)
            kpart = (k.eq.iatom .or. kz.eq.iatom .or. kx.eq.iatom)
            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 = ((ipart.or.kpart) .and.
     &                                  (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) - xi
               yr = y(k) - yi
               zr = z(k) - zi
               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 empik1 (ii,kk,xr,yr,zr,r,r2,rpi,
     &                         rpk,indi,indk,eik,ei,ek,
     &                         dm,dmi,dmk,dp,dpi,dpk,utu)
c
c     use shifted energy switching if near the cutoff distance
c
                  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
                     dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                              + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                     trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                                  + f3*r3 + f2*r2 + f1*r + f0)
                     dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5
     &                                  + 5.0d0*f5*r4 + 4.0d0*f4*r3
     &                              + 3.0d0*f3*r2 + 2.0d0*f2*r + f1)
                     shift = fik / (0.5d0*(off+cut))
                     eik = eik - shift
                     de = eik * dtaper + dtrans
                     dm(1) = dm(1)*taper + de*(xr/r)
                     dm(2) = dm(2)*taper + de*(yr/r)
                     dm(3) = dm(3)*taper + de*(zr/r)
                     de = (2.0d0*(ei+ek)+utu) * dtaper
                     dp(1) = dp(1)*taper + de*(xr/r)
                     dp(2) = dp(2)*taper + de*(yr/r)
                     dp(3) = dp(3)*taper + de*(zr/r)
                     do j = 1, 3
                        do jj = 1, 3
                           dmi(jj,j) = dmi(jj,j) * taper
                           dmk(jj,j) = dmk(jj,j) * taper
                           dpi(jj,j) = dpi(jj,j) * taper
                           dpk(jj,j) = dpk(jj,j) * taper
                        end do
                     end do
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group) then
                     do j = 1, 3
                        dm(j) = dm(j) * fgrp
                        dp(j) = dp(j) * fgrp
                        do jj = 1, 3
                           dmi(jj,j) = dmi(jj,j) * fgrp
                           dmk(jj,j) = dmk(jj,j) * fgrp
                           dpi(jj,j) = dpi(jj,j) * fgrp
                           dpk(jj,j) = dpk(jj,j) * fgrp
                        end do
                     end do
                  end if
c
c     increment the multipole first derivative expressions
c
                  dem(1,i) = dem(1,i) - dm(1) + dmi(1,1)
                  dem(2,i) = dem(2,i) - dm(2) + dmi(1,2)
                  dem(3,i) = dem(3,i) - dm(3) + dmi(1,3)
                  dem(1,iz) = dem(1,iz) + dmi(2,1)
                  dem(2,iz) = dem(2,iz) + dmi(2,2)
                  dem(3,iz) = dem(3,iz) + dmi(2,3)
                  dem(1,ix) = dem(1,ix) + dmi(3,1)
                  dem(2,ix) = dem(2,ix) + dmi(3,2)
                  dem(3,ix) = dem(3,ix) + dmi(3,3)
                  dem(1,k) = dem(1,k) + dm(1) + dmk(1,1)
                  dem(2,k) = dem(2,k) + dm(2) + dmk(1,2)
                  dem(3,k) = dem(3,k) + dm(3) + dmk(1,3)
                  dem(1,kz) = dem(1,kz) + dmk(2,1)
                  dem(2,kz) = dem(2,kz) + dmk(2,2)
                  dem(3,kz) = dem(3,kz) + dmk(2,3)
                  dem(1,kx) = dem(1,kx) + dmk(3,1)
                  dem(2,kx) = dem(2,kx) + dmk(3,2)
                  dem(3,kx) = dem(3,kx) + dmk(3,3)
c
c     increment the polarization first derivative expressions
c
                  dep(1,i) = dep(1,i) - dp(1) + dpi(1,1)
                  dep(2,i) = dep(2,i) - dp(2) + dpi(1,2)
                  dep(3,i) = dep(3,i) - dp(3) + dpi(1,3)
                  dep(1,iz) = dep(1,iz) + dpi(2,1)
                  dep(2,iz) = dep(2,iz) + dpi(2,2)
                  dep(3,iz) = dep(3,iz) + dpi(2,3)
                  dep(1,ix) = dep(1,ix) + dpi(3,1)
                  dep(2,ix) = dep(2,ix) + dpi(3,2)
                  dep(3,ix) = dep(3,ix) + dpi(3,3)
                  dep(1,k) = dep(1,k) + dp(1) + dpk(1,1)
                  dep(2,k) = dep(2,k) + dp(2) + dpk(1,2)
                  dep(3,k) = dep(3,k) + dp(3) + dpk(1,3)
                  dep(1,kz) = dep(1,kz) + dpk(2,1)
                  dep(2,kz) = dep(2,kz) + dpk(2,2)
                  dep(3,kz) = dep(3,kz) + dpk(2,3)
                  dep(1,kx) = dep(1,kx) + dpk(3,1)
                  dep(2,kx) = dep(2,kx) + dpk(3,2)
                  dep(3,kx) = dep(3,kx) + dpk(3,3)
               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)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         iz = zaxis(ii)
         ix = xaxis(ii)
         ipart = (i.eq.iatom .or. iz.eq.iatom .or. ix.eq.iatom)
         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)
            kpart = (k.eq.iatom .or. kz.eq.iatom .or. kx.eq.iatom)
            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 = ((ipart.or.kpart) .and.
     &                                  (iuse.or.kuse))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do m = 1, ncell
                  xr = x(k) - xi
                  yr = y(k) - yi
                  zr = z(k) - zi
                  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 empik1 (ii,kk,xr,yr,zr,r,r2,rpi,
     &                            rpk,indi,indk,eik,ei,ek,
     &                            dm,dmi,dmk,dp,dpi,dpk,utu)
c
c     use shifted energy switching if near the cutoff distance
c
                     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
                        dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3
     &                                 + 3.0d0*c3*r2 + 2.0d0*c2*r + c1
                        trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4
     &                                     + f3*r3 + f2*r2 + f1*r + f0)
                        dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5
     &                                     + 5.0d0*f5*r4 + 4.0d0*f4*r3
     &                                 + 3.0d0*f3*r2 + 2.0d0*f2*r + f1)
                        shift = fik / (0.5d0*(off+cut))
                        eik = eik - shift
                        de = eik * dtaper + dtrans
                        dm(1) = dm(1)*taper + de*(xr/r)
                        dm(2) = dm(2)*taper + de*(yr/r)
                        dm(3) = dm(3)*taper + de*(zr/r)
                        de = (2.0d0*(ei+ek)+utu) * dtaper
                        dp(1) = dp(1)*taper + de*(xr/r)
                        dp(2) = dp(2)*taper + de*(yr/r)
                        dp(3) = dp(3)*taper + de*(zr/r)
                        do j = 1, 3
                           do jj = 1, 3
                              dmi(jj,j) = dmi(jj,j) * taper
                              dmk(jj,j) = dmk(jj,j) * taper
                              dpi(jj,j) = dpi(jj,j) * taper
                              dpk(jj,j) = dpk(jj,j) * taper
                           end do
                        end do
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group) then
                        do j = 1, 3
                           dm(j) = dm(j) * fgrp
                           dp(j) = dp(j) * fgrp
                           do jj = 1, 3
                              dmi(jj,j) = dmi(jj,j) * fgrp
                              dmk(jj,j) = dmk(jj,j) * fgrp
                              dpi(jj,j) = dpi(jj,j) * fgrp
                              dpk(jj,j) = dpk(jj,j) * fgrp
                           end do
                        end do
                     end if
c
c     increment the multipole first derivative expressions
c
                     dem(1,i) = dem(1,i) - dm(1) + dmi(1,1)
                     dem(2,i) = dem(2,i) - dm(2) + dmi(1,2)
                     dem(3,i) = dem(3,i) - dm(3) + dmi(1,3)
                     dem(1,iz) = dem(1,iz) + dmi(2,1)
                     dem(2,iz) = dem(2,iz) + dmi(2,2)
                     dem(3,iz) = dem(3,iz) + dmi(2,3)
                     dem(1,ix) = dem(1,ix) + dmi(3,1)
                     dem(2,ix) = dem(2,ix) + dmi(3,2)
                     dem(3,ix) = dem(3,ix) + dmi(3,3)
                     if (i .ne. k) then
                        dem(1,k) = dem(1,k) + dm(1) + dmk(1,1)
                        dem(2,k) = dem(2,k) + dm(2) + dmk(1,2)
                        dem(3,k) = dem(3,k) + dm(3) + dmk(1,3)
                        dem(1,kz) = dem(1,kz) + dmk(2,1)
                        dem(2,kz) = dem(2,kz) + dmk(2,2)
                        dem(3,kz) = dem(3,kz) + dmk(2,3)
                        dem(1,kx) = dem(1,kx) + dmk(3,1)
                        dem(2,kx) = dem(2,kx) + dmk(3,2)
                        dem(3,kx) = dem(3,kx) + dmk(3,3)
                     end if
c
c     increment the polarization first derivative expressions
c
                     dep(1,i) = dep(1,i) - dp(1) + dpi(1,1)
                     dep(2,i) = dep(2,i) - dp(2) + dpi(1,2)
                     dep(3,i) = dep(3,i) - dp(3) + dpi(1,3)
                     dep(1,iz) = dep(1,iz) + dpi(2,1)
                     dep(2,iz) = dep(2,iz) + dpi(2,2)
                     dep(3,iz) = dep(3,iz) + dpi(2,3)
                     dep(1,ix) = dep(1,ix) + dpi(3,1)
                     dep(2,ix) = dep(2,ix) + dpi(3,2)
                     dep(3,ix) = dep(3,ix) + dpi(3,3)
                     if (i .ne. k) then
                        dep(1,k) = dep(1,k) + dp(1) + dpk(1,1)
                        dep(2,k) = dep(2,k) + dp(2) + dpk(1,2)
                        dep(3,k) = dep(3,k) + dp(3) + dpk(1,3)
                        dep(1,kz) = dep(1,kz) + dpk(2,1)
                        dep(2,kz) = dep(2,kz) + dpk(2,2)
                        dep(3,kz) = dep(3,kz) + dpk(2,3)
                        dep(1,kx) = dep(1,kx) + dpk(3,1)
                        dep(2,kx) = dep(2,kx) + dpk(3,2)
                        dep(3,kx) = dep(3,kx) + dpk(3,3)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
