c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine induce  --  evaluate induced dipole moments  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "induce" computes the induced dipole moment at each
c     polarizable site due to direct or mutual polarization
c
c
      subroutine induce
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'potent.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k,m,skip(maxatm)
      integer ii,iz,ix,kk,kz,kx
      integer iter,maxiter
      real*8 eps,norm
      real*8 xr,yr,zr,taper
      real*8 r,r2,r3,r4,r5
      real*8 rpi(13),rpk(13)
      real*8 udir(3,maxatm)
      real*8 uold(3,maxatm)
      real*8 fieldi(3),fieldk(3)
      logical iuse,kuse
c
c
c     zero out induced dipoles and count the polarizable sites
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
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
      call switch ('CHARGE')
c
c     compute the direct induced dipole moment at each atom
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 kk = ii+1, npole
            k = ipole(kk)
            kz = zaxis(kk)
            kx = xaxis(kk)
            kuse = (use(k) .or. use(kz) .or. use(kx))
            if (iuse .or. kuse) then
               if (skip(k) .ne. i) 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
                     r = sqrt(r2)
                     do j = 1, maxpole
                        rpk(j) = rpole(j,kk)
                     end do
                     call udirect (ii,kk,xr,yr,zr,r,r2,rpi,
     &                                rpk,fieldi,fieldk)
                     if (r2 .gt. cut2) then
                        r3 = r2 * r
                        r4 = r2 * r2
                        r5 = r2 * r3
                        taper = c5*r5 + c4*r4 + c3*r3
     &                             + c2*r2 + c1*r + c0
                        do j = 1, 3
                           fieldi(j) = fieldi(j) * taper
                           fieldk(j) = fieldk(j) * taper
                        end do
                     end if
                     do j = 1, 3
                        uind(j,ii) = uind(j,ii) + fieldi(j)
                        uind(j,kk) = uind(j,kk) + fieldk(j)
                     end do                 
                  end if
               end if
            end if
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         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 kk = ii, npole
               k = ipole(kk)
               kz = zaxis(kk)
               kx = xaxis(kk)
               kuse = (use(k) .or. use(kz) .or. use(kx))
               if (iuse .or. kuse) 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
                        r = sqrt(r2)
                        do j = 1, maxpole
                           rpk(j) = rpole(j,kk)
                        end do
                        call udirect (ii,kk,xr,yr,zr,r,r2,rpi,
     &                                   rpk,fieldi,fieldk)
                        if (r2 .gt. cut2) then
                           r3 = r2 * r
                           r4 = r2 * r2
                           r5 = r2 * r3
                           taper = c5*r5 + c4*r4 + c3*r3
     &                                + c2*r2 + c1*r + c0
                           do j = 1, 3
                              fieldi(j) = fieldi(j) * taper
                              fieldk(j) = fieldk(j) * taper
                           end do
                        end if
                        do j = 1, 3
                           uind(j,ii) = uind(j,ii) + fieldi(j)
                           if (ii .ne. kk)
     &                        uind(j,kk) = uind(j,kk) + fieldk(j)
                        end do                 
                     end if
                  end do
               end if
            end do
         end do
      end if
c
c     convert total field at each atom to induced dipole moment
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = polarize(i) * uind(j,i)
         end do
      end do
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         maxiter = 100
         iter = 0
         eps = 1.0d0
         do i = 1, npole
            do j = 1, 3
               udir(j,i) = uind(j,i)
            end do
         end do
c
c     compute mutual induced dipole moments by an iterative method
c
         dowhile (iter.lt.maxiter .and. eps.gt.poleps)
            do ii = 1, npole
               do j = 1, 3
                  uold(j,ii) = uind(j,ii)
                  uind(j,ii) = 0.0d0
               end do
            end do
            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 kk = ii+1, npole
                  k = ipole(kk)
                  kz = zaxis(kk)
                  kx = xaxis(kk)
                  kuse = (use(k) .or. use(kz) .or. use(kx))
                  if (iuse .or. kuse) then
                     if (skip(k) .ne. i) 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
                           r = sqrt(r2)
                           call umutual (ii,kk,xr,yr,zr,r,r2,uold(1,ii),
     &                                      uold(1,kk),fieldi,fieldk)
                           if (r2 .gt. cut2) then
                              r3 = r2 * r
                              r4 = r2 * r2
                              r5 = r2 * r3
                              taper = c5*r5 + c4*r4 + c3*r3
     &                                   + c2*r2 + c1*r + c0
                              do j = 1, 3
                                 fieldi(j) = fieldi(j) * taper
                                 fieldk(j) = fieldk(j) * taper
                              end do
                           end if
                           do j = 1, 3
                              uind(j,ii) = uind(j,ii) + fieldi(j)
                              uind(j,kk) = uind(j,kk) + fieldk(j)
                           end do                 
                        end if
                     end if
                  end if
               end do
            end do
c
c     periodic boundary for large cutoffs via replicates method
c
            if (use_replica) then
               do ii = 1, npole
                  i = ipole(ii)
                  iz = zaxis(ii)
                  ix = xaxis(ii)
                  iuse = (use(i) .or. use(iz) .or. use(ix))
                  do kk = ii, npole
                     k = ipole(kk)
                     kz = zaxis(kk)
                     kx = xaxis(kk)
                     kuse = (use(k) .or. use(kz) .or. use(kx))
                     if (iuse .or. kuse) 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
                              r = sqrt(r2)
                              call umutual (ii,kk,xr,yr,zr,r,r2,
     &                                      uold(1,ii),uold(1,kk),
     &                                         fieldi,fieldk)
                              if (r2 .gt. cut2) then
                                 r3 = r2 * r
                                 r4 = r2 * r2
                                 r5 = r2 * r3
                                 taper = c5*r5 + c4*r4 + c3*r3
     &                                      + c2*r2 + c1*r + c0
                                 do j = 1, 3
                                    fieldi(j) = fieldi(j) * taper
                                    fieldk(j) = fieldk(j) * taper
                                 end do
                              end if
                              do j = 1, 3
                                 uind(j,ii) = uind(j,ii) + fieldi(j)
                                 if (ii .ne. kk)
     &                              uind(j,kk) = uind(j,kk) + fieldk(j)
                              end do                 
                           end if
                        end do
                     end if
                  end do
               end do
            end if
c
c     check to see if the mutual induced dipoles have converged
c
            iter = iter + 1
            eps = 0.0d0
            do i = 1, npole
               do j = 1, 3
                  uind(j,i) = udir(j,i) + polarize(i)*uind(j,i)
                  eps = eps + (uind(j,i)-uold(j,i))**2
               end do
            end do
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,10)
   10             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debyes)',/)
               end if
               write (iout,20)  iter,eps
   20          format (i8,7x,f16.10)
            end if
         end do
c
c     terminate the calculation if dipoles failed to converge
c
         if (eps .gt. poleps) then
            write (iout,30)
   30       format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                 ' not Converged')
            call prterr
            call fatal
         end if
      end if
c
c     print out a list of the final induced dipole moments
c
      if (debug) then
         write (iout,40)
   40    format (/,' Induced Dipole Moments (Debyes) :',
     &           //,4x,'Atom',14x,'X',11x,'Y',11x,'Z',9x,'Total'/)
         do i = 1, npole
            if (polarize(i) .ne. 0.0d0) then
               k = ipole(i)
               norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
               write (iout,50)  k,(debye*uind(j,i),j=1,3),debye*norm
   50          format (i8,5x,4f12.4)
            end if
         end do
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine udirect  --  field for direct induced dipoles  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "udirect" evaluates the electric field at a polarizable atom
c     due to permanent atomic multipoles at a second atom, and vice
c     versa, for use in computation of direct induced dipole moments
c
c
      subroutine udirect (ii,kk,xr,yr,zr,r,r2,rpi,rpk,fieldi,fieldk)
      implicit none
      include 'sizes.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      integer i,ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,damp
      real*8 rr3,rr5,rr7
      real*8 xr5,yr5,xyz
      real*8 xr7,yr7,rr53
      real*8 t2,t3,t4,t5,t6,t7,t8,t9,t10,t11
      real*8 t12,t13,t14,t15,t16,t17,t18,t19
      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 i9i4,i9i7,k4k9,k7k9
      real*8 rpi(13),rpk(13)
      real*8 fieldi(3),fieldk(3)
      logical iquad,kquad
c
c
c     set extent of the multipole expansion at each site
c
      iquad = (polsiz(ii) .ge. 13)
      kquad = (polsiz(kk) .ge. 13)
c
c     compute the first order T2 matrix elements
c
      rr3 = -1.0d0 / (r2*r)
      t2 = xr * rr3
      t3 = yr * rr3
      t4 = zr * rr3
c
c     compute the second order T2 matrix elements
c
      rr5 = -3.0d0 * rr3 / r2
      xr5 = xr * rr5
      yr5 = yr * rr5
      t5 = rr3 + xr5*xr
      t6 = xr5 * yr
      t7 = xr5 * zr
      t8 = rr3 + yr5*yr
      t9 = yr5 * zr
      t10 = -t5 - t8
c
c     compute the third order T2 matrix elements
c
      if (iquad .or. kquad) then
         rr7 = -5.0d0 * rr5 / r2
         xyz = xr * yr * zr
         xr7 = xr * xr * rr7
         yr7 = yr * yr * rr7
         rr53 = 3.0d0 * rr5
         t11 = xr * (xr7+rr53)
         t12 = yr * (xr7+rr5)
         t13 = zr * (xr7+rr5)
         t14 = xr * (yr7+rr5)
         t15 = xyz * rr7
         t16 = -t11 - t14
         t17 = yr * (yr7+rr53)
         t18 = zr * (yr7+rr5)
         t19 = -t12 - t17
      end if
c
c     compute the field at site k due to multipoles at site i
c
      i0 = rpi(1)
      i1 = rpi(2)
      i2 = rpi(3)
      i3 = rpi(4)
      fieldk(1) = -i0*t2 + i1*t5 + i2*t6 + i3*t7
      fieldk(2) = -i0*t3 + i1*t6 + i2*t8 + i3*t9
      fieldk(3) = -i0*t4 + i1*t7 + i2*t9 + i3*t10
      if (iquad) then
         i4 = rpi(5)
         i5 = rpi(6)
         i6 = rpi(7)
         i7 = rpi(9)
         i8 = rpi(10)
         i9 = rpi(13)
         i9i4 = i9 - i4
         i9i7 = i9 - i7
         fieldk(1) = fieldk(1) + i9i4*t11 + i9i7*t14
     &                  - 2.0d0*(i5*t12 + i6*t13 + i8*t15)
         fieldk(2) = fieldk(2) + i9i4*t12 + i9i7*t17
     &                  - 2.0d0*(i5*t14 + i6*t15 + i8*t18)
         fieldk(3) = fieldk(3) + i9i4*t13 + i9i7*t18
     &                  - 2.0d0*(i5*t15 + i6*t16 + i8*t19)
      end if
c
c     compute the field at site i due to multipoles at site k
c
      k0 = rpk(1)
      k1 = rpk(2)
      k2 = rpk(3)
      k3 = rpk(4)
      fieldi(1) = k0*t2 + k1*t5 + k2*t6 + k3*t7
      fieldi(2) = k0*t3 + k1*t6 + k2*t8 + k3*t9
      fieldi(3) = k0*t4 + k1*t7 + k2*t9 + k3*t10
      if (kquad) then
         k4 = rpk(5)
         k5 = rpk(6)
         k6 = rpk(7)
         k7 = rpk(9)
         k8 = rpk(10)
         k9 = rpk(13)
         k4k9 = k4 - k9
         k7k9 = k7 - k9
         fieldi(1) = fieldi(1) + k4k9*t11 + k7k9*t14
     &                  + 2.0d0*(k5*t12 + k6*t13 + k8*t15)
         fieldi(2) = fieldi(2) + k4k9*t12 + k7k9*t17
     &                  + 2.0d0*(k5*t14 + k6*t15 + k8*t18)
         fieldi(3) = fieldi(3) + k4k9*t13 + k7k9*t18
     &                  + 2.0d0*(k5*t15 + k6*t16 + k8*t19)
      end if
c
c     apply a damping factor to reduce the field at short range
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)
            do i = 1, 3
               fieldi(i) = fieldi(i) * damp
               fieldk(i) = fieldk(i) * damp
            end do
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine umutual  --  field for mutual induced dipoles  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "umutual" evaluates the electric field at a polarizable atom
c     due to the induced atomic dipoles at a second atom, and vice
c     versa, for use in computation of mutual induced dipole moments
c
c
      subroutine umutual (ii,kk,xr,yr,zr,r,r2,upi,upk,fieldi,fieldk)
      implicit none
      include 'sizes.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      integer i,ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,damp
      real*8 rr3,rr5,xr5,yr5
      real*8 upi(3),upk(3)
      real*8 fieldi(3),fieldk(3)
      real*8 u1,u2,u3,v1,v2,v3
      real*8 t5,t6,t7,t8,t9,t10
c
c
c     set the current values of the induced dipoles
c
      u1 = upi(1)
      u2 = upi(2)
      u3 = upi(3)
      v1 = upk(1)
      v2 = upk(2)
      v3 = upk(3)
c
c     compute the second order T2 matrix elements
c
      rr3 = -1.0d0 / (r2*r)
      rr5 = -3.0d0 * rr3 / r2
      xr5 = xr * rr5
      yr5 = yr * rr5
      t5 = rr3 + xr5*xr
      t6 = xr5 * yr
      t7 = xr5 * zr
      t8 = rr3 + yr5*yr
      t9 = yr5 * zr
      t10 = -t5 - t8
c
c     compute the field at atom i due to atom k and vice versa
c
      fieldi(1) = v1*t5 + v2*t6 + v3*t7
      fieldi(2) = v1*t6 + v2*t8 + v3*t9
      fieldi(3) = v1*t7 + v2*t9 + v3*t10
      fieldk(1) = u1*t5 + u2*t6 + u3*t7
      fieldk(2) = u1*t6 + u2*t8 + u3*t9
      fieldk(3) = u1*t7 + u2*t9 + u3*t10
c
c     apply a damping factor to reduce the field at short range
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)
            do i = 1, 3
               fieldi(i) = fieldi(i) * damp
               fieldk(i) = fieldk(i) * damp
            end do
         end if
      end if
      return
      end
