c
c
c     #############################################################
c     ##  COPYRIGHT (C) 2001 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  program polstar  --  manipulate multipole and polarization  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "polstar" computes an output set of TINKER multipole parmeters
c     which when used with an intramolecular polarization model will
c     give the same electrostatic potential around the molecule as
c     the input set of multipole parameters in the absence of any
c     intramolecular polarization
c
c     for example, the input parameters could be from a distributed
c     multipole analysis of a molecular wavefunction and the output
c     will be the parameter values that achieve the same potential
c     in the presence of intramolecular polarization; if the force
c     field model does not contain intramolecular polarization, then
c     the output parameters will be the same as the input values
c
c
      program polstar
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,ia
      integer iz,ix
      real*8 a(3,3)
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotsite (i,a)
      end do
c
c     compute induced dipoles to be removed from QM multipoles
c
      call polstar1
c
c     remove induced dipole from global frame multipoles
c
      do i = 1, npole
         rpole(2,i) = rpole(2,i) - uind(1,i)
         rpole(3,i) = rpole(3,i) - uind(2,i)
         rpole(4,i) = rpole(4,i) - uind(3,i)
         do j = 1, 13
            pole(j,i) = rpole(j,i)
         end do
      end do
c
c     rotate the multipoles from global back to local frame
c
      do i = 1, npole
         call rotmat (i,a)
         call invert (3,3,a)
         call rotsite (i,a)
      end do
c
c     copy the final multipoles back into local frame array
c
      do i = 1, npole
         do j = 1, 13
            pole(j,i) = rpole(j,i)
         end do
      end do
c
c     print multipoles for use with intramolecular polarization
c
      write (iout,10)
   10 format (/,' Atomic Multipoles Modified for Intramolecular',
     &           ' Polarization :',
     &        //,10x,'Atom Number',3x,'Local Axes',
     &           ' Definition',10x,'Multipole Moments',/)
      do i = 1, npole
         ia = ipole(i)
         iz = zaxis(i)
         ix = xaxis(i)
         if (iz .gt. n)  iz = 0
         if (ix .gt. n)  ix = 0
         do j = 2, 4
            pole(j,i) = pole(j,i) / bohr
         end do
         do j = 5, 13
            pole(j,i) = 3.0d0 * pole(j,i) / bohr**2
         end do
         write (iout,20)  i,ia,iz,ix,polaxe(i),
     &                    (pole(j,i),j=1,5),pole(8,i),
     &                    pole(9,i),(pole(j,i),j=11,13)
   20    format (i6,3x,i6,6x,i6,1x,i6,3x,a8,4x,f9.5,/,49x,3f9.5,
     &              /,49x,f9.5,/,49x,2f9.5,/,49x,3f9.5)
      end do
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine polstar1  --  induced dipoles via double loop  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine polstar1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'potent.i'
      include 'units.i'
      integer i,j,k
      integer iter,maxiter
      integer ii,ix,iz
      integer kk,kx,kz
      real*8 r,r2,xr,yr,zr
      real*8 rr3,rr5,rr7
      real*8 r3,r4,r5
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 ukx,uky,ukz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,uir,dkr,ukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 eps,epsold
      real*8 damp,taper
      real*8 scale3,scale5
      real*8 scale7,norm
      real*8 fi(3),fk(3)
      real*8 field(3,maxatm)
      real*8 udir(3,maxatm)
      real*8 uold(3,maxatm)
      real*8 pscale(maxatm)
      logical done
c
c
c     zero out the induced dipole and the field at each site
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = 0.0d0
            field(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     compute the direct induced dipole moment at each atom
c
      do i = 1, npole-1
         ii = ipole(i)
         iz = zaxis(ii)
         ix = xaxis(ii)
         ci = rpole(1,i)
         dix = rpole(2,i)
         diy = rpole(3,i)
         diz = rpole(4,i)
         qixx = rpole(5,i)
         qixy = rpole(6,i)
         qixz = rpole(7,i)
         qiyy = rpole(9,i)
         qiyz = rpole(10,i)
         qizz = rpole(13,i)
         do j = i+1, npole
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, np11(ii)
            pscale(ip11(j,ii)) = d1scale
         end do
         do j = 1, np12(ii)
            pscale(ip12(j,ii)) = d2scale
         end do
         do j = 1, np13(ii)
            pscale(ip13(j,ii)) = d3scale
         end do
         do j = 1, np14(ii)
            pscale(ip14(j,ii)) = d4scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            kz = zaxis(kk)
            kx = xaxis(kk)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            r2 = xr*xr + yr* yr + zr*zr
            r = sqrt(r2)
            ck = rpole(1,k)
            dkx = rpole(2,k)
            dky = rpole(3,k)
            dkz = rpole(4,k)
            qkxx = rpole(5,k)
            qkxy = rpole(6,k)
            qkxz = rpole(7,k)
            qkyy = rpole(9,k)
            qkyz = rpole(10,k)
            qkzz = rpole(13,k)
            scale3 = pscale(kk) 
            scale5 = pscale(kk)
            scale7 = pscale(kk)
            damp = pdamp(i) * pdamp(k)
            if (damp .ne. 0.0d0) then
               damp = -pgamma * (r/damp)**3
               if (damp .gt. -50.0d0) then
                  scale3 = scale3 * (1.0d0-exp(damp))
                  scale5 = scale5 * (1.0d0-(1.0d0-damp)*exp(damp))
                  scale7 = scale7 * (1.0d0-(1.0d0-damp+0.6d0*damp**2)
     &                                               *exp(damp))
               end if
            end if
            rr3 = scale3 / (r*r2)
            rr5 = 3.0d0 * scale5 / (r*r2*r2)
            rr7 = 15.0d0 * scale7 / (r*r2*r2*r2)
            dir = dix*xr + diy*yr + diz*zr
            qix = qixx*xr + qixy*yr + qixz*zr
            qiy = qixy*xr + qiyy*yr + qiyz*zr
            qiz = qixz*xr + qiyz*yr + qizz*zr
            qir = qix*xr + qiy*yr + qiz*zr
            dkr = dkx*xr + dky*yr + dkz*zr
            qkx = qkxx*xr + qkxy*yr + qkxz*zr
            qky = qkxy*xr + qkyy*yr + qkyz*zr
            qkz = qkxz*xr + qkyz*yr + qkzz*zr
            qkr = qkx*xr + qky*yr + qkz*zr
            fi(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                 - rr3*dkx + 2.0d0*rr5*qkx
            fi(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                 - rr3*dky + 2.0d0*rr5*qky
            fi(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr)
     &                 - rr3*dkz + 2.0d0*rr5*qkz
            fk(1) = xr*(rr3*ci+rr5*dir+rr7*qir)
     &                 - rr3*dix - 2.0d0*rr5*qix
            fk(2) = yr*(rr3*ci+rr5*dir+rr7*qir)
     &                 - rr3*diy - 2.0d0*rr5*qiy
            fk(3) = zr*(rr3*ci+rr5*dir+rr7*qir)
     &                 - rr3*diz - 2.0d0*rr5*qiz
            do j = 1, 3
               field(j,i) = field(j,i) + fi(j)
               field(j,k) = field(j,k) + fk(j)
            end do
         end do
      end do
c
c     compute induced dipoles as polarizability times field
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = polarity(i) * field(j,i)
         end do
      end do
c
c     for direct-only models set mutual scale factors to zero
c
      if (poltyp .eq. 'DIRECT') then
         u1scale = 0.0d0
         u2scale = 0.0d0
         u3scale = 0.0d0
         u4scale = 0.0d0
      end if
c
c     set tolerances for computation of mutual induced dipoles
c
      done = .false.
      maxiter = 500
      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 (.not. done)
         do i = 1, npole
            do j = 1, 3
               field(j,i) = 0.0d0
            end do
         end do
         do i = 1, npole-1
            ii = ipole(i)
            iz = zaxis(ii)
            ix = xaxis(ii)
            uix = uind(1,i)
            uiy = uind(2,i)
            uiz = uind(3,i)
            do j = i+1, npole
               pscale(ipole(j)) = 0.0d0
            end do
            do j = 1, np11(ii)
               pscale(ip11(j,ii)) = u1scale - d1scale
            end do
            do j = 1, np12(ii)
               pscale(ip12(j,ii)) = u2scale - d2scale
            end do
            do j = 1, np13(ii)
               pscale(ip13(j,ii)) = u3scale - d3scale
            end do
            do j = 1, np14(ii)
               pscale(ip14(j,ii)) = u4scale - d4scale
            end do
            do k = i+1, npole
               kk = ipole(k)
               kz = zaxis(kk)
               kx = xaxis(kk)
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               r2 = xr*xr + yr* yr + zr*zr
               r = sqrt(r2)
               ukx = uind(1,k)
               uky = uind(2,k)
               ukz = uind(3,k)
               scale3 = pscale(kk) 
               scale5 = pscale(kk)
               damp = pdamp(i) * pdamp(k)
               if (damp .ne. 0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = scale3*(1.0d0-exp(damp))
                     scale5 = scale5*(1.0d0-(1.0d0-damp)*exp(damp))
                  end if
               end if
               rr3 = scale3 / (r*r2)
               rr5 = 3.0d0 * scale5 / (r*r2*r2)
               uir = xr*uix + yr*uiy + zr*uiz
               ukr = xr*ukx + yr*uky + zr*ukz
               fi(1) = -rr3*ukx + rr5*ukr*xr
               fi(2) = -rr3*uky + rr5*ukr*yr
               fi(3) = -rr3*ukz + rr5*ukr*zr
               fk(1) = -rr3*uix + rr5*uir*xr
               fk(2) = -rr3*uiy + rr5*uir*yr
               fk(3) = -rr3*uiz + rr5*uir*zr
               do j = 1, 3
                  field(j,i) = field(j,i) + fi(j)
                  field(j,k) = field(j,k) + fk(j)
               end do
            end do
         end do
c
c     check to see if the mutual induced dipoles have converged
c
         iter = iter + 1
         epsold = eps
         eps = 0.0d0
         do i = 1, npole
            do j = 1, 3
               uold(j,i) = uind(j,i)
               uind(j,i) = udir(j,i) + polarity(i)*field(j,i)
               uind(j,i) = uold(j,i) + polsor*(uind(j,i)-uold(j,i))
               eps = eps + (uind(j,i)-uold(j,i))**2
            end do
         end do
         eps = debye * sqrt(eps/dble(npolar))
         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)
         if (eps .lt. poleps)  done = .true.
         if (eps .gt. epsold)  done = .true.
         if (iter .ge. maxiter)  done = .true.
      end do
c
c     terminate the calculation if dipoles failed to converge
c
      if (eps .gt. poleps) then
         write (iout,30)
   30    format (/,' POLSTAR1  --  Warning, Induced Dipoles',
     &              ' are not Converged')
         call prterr
         call fatal
      end if
c
c     print out a list of the final induced dipole moments
c
      write (iout,40)
   40 format (/,' Induced Dipole Moments in Global Frame (Debyes) :')
      write (iout,50)
   50 format (/,4x,'Atom',14x,'X',11x,'Y',11x,'Z',
     &           9x,'Total'/)
      do i = 1, npole
         k = ipole(i)
         norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
         write (iout,60)  k,(debye*uind(j,i),j=1,3),debye*norm
   60    format (i8,5x,4f12.4)
      end do
      return
      end
