c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine kmpole  --  multipole parameter assignment  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "kmpole" assigns atomic multipole moments to the atoms of
c     the structure and processes any new or changed values
c
c
      subroutine kmpole
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kmulti.i'
      include 'mpole.i'
      include 'potent.i'
      include 'units.i'
      integer i,j,k,m,it,mt,imp,nmp
      integer size,next,number
      integer kz,kx,ztyp,xtyp
      integer mpt(maxnmp),mpkey(maxnmp)
      integer mpz(maxnmp),mpx(maxnmp)
      integer start(maxtyp),stop(maxtyp)
      real*8 mpl(13)
      character*3 pa,pb,pc
      character*8 axt
      character*9 pt
      character*20 keyword
      character*80 record,string
      logical header
c
c
c     process keywords containing atomic multipole parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            k = 0
            kz = 0
            kx = 0
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=50,end=50)  k,kz,kx,mpl(1)
            if (k .gt. 0) then
               if (kx .lt. 0)  axt = 'Bisector'
               kz = abs(kz)
               kx = abs(kx)
               record = keyline(i+1)
               read (record,*,err=50,end=50)  (mpl(j),j=2,4)
               record = keyline(i+2)
               read (record,*,err=50,end=50)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=50,end=50)  (mpl(j),j=8,9)
               record = keyline(i+4)
               read (record,*,err=50,end=50)  (mpl(j),j=11,13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Additional Atomic Multipole Parameters :',
     &                    //,6x,'Atom Type',5x,'Local Axes Definition',
     &                       10x,'Multipole Moments',/)
               end if
               write (iout,20)  k,kz,kx,axt,(mpl(j),j=1,5),
     &                             mpl(8),mpl(9),(mpl(j),j=11,13)
   20          format (6x,i6,5x,i6,1x,i6,3x,a8,4x,f9.5,/,45x,3f9.5,
     &                       /,45x,f9.5,/,45x,2f9.5,/,45x,3f9.5)
               size = 3
               call numeral (k,pa,size)
               call numeral (kz,pb,size)
               call numeral (kx,pc,size)
               pt = pa//pb//pc
               do j = 1, maxnmp
                  if (kmp(j).eq.'         ' .or. kmp(j).eq.pt) then
                     kmp(j) = pt
                     mpaxis(j) = axt
                     do m = 1, 13
                        multip(m,j) = mpl(m)
                     end do
                     goto 40
                  end if
               end do
               write (iout,30)
   30          format (/,' KMPOLE  --  Too many Atomic Multipole',
     &                    ' Parameters')
               abort = .true.
   40          continue
            end if
   50       continue
         end if
      end do
c
c     zero out local axis definitions and multipoles for each atom
c
      do i = 1, n
         zaxis(i) = 0
         xaxis(i) = 0
         polaxe(i) = '        '
         do j = 1, 13
            pole(j,i) = 0.0d0
         end do
      end do
c
c     set indices into the list of atomic multipoles
c
      nmp = 0
      dowhile (kmp(nmp+1) .ne. '         ')
         nmp = nmp + 1
         mpt(nmp) = number(kmp(nmp)(1:3))
         mpz(nmp) = number(kmp(nmp)(4:6))
         mpx(nmp) = number(kmp(nmp)(7:9))
      end do
      call sort3 (nmp,mpt,mpkey)
      do i = 1, maxtyp
         start(i) = 0
         stop(i) = 0
      end do
      do i = 1, nmp
         k = mpt(i)
         if (start(k) .eq. 0)  start(k) = i
      end do
      do i = nmp, 1, -1
         k = mpt(i)
         if (stop(k) .eq. 0)  stop(k) = i
      end do
c
c     assign atomic multipole parameters to each atom
c
      do i = 1, n
         it = type(i)
         if (start(it) .ne. 0) then
            do j = start(it), stop(it)
               imp = mpkey(j)
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               if (n12(i) .eq. 0) then
                  zaxis(i) = 1
                  xaxis(i) = 2
                  if (i .eq. 1)  zaxis(i) = 3
                  if (i .eq. 2)  xaxis(i) = 3
                  goto 60
               end if
               do k = 1, n12(i)
                  if (type(i12(k,i)) .eq. ztyp) then
                     if (n12(i) .ge. 2) then
                        do m = 1, n12(i)
                           mt = type(i12(m,i))
                           if (mt.eq.xtyp .and. m.ne.k) then
                              zaxis(i) = i12(k,i)
                              xaxis(i) = i12(m,i)
                              goto 60
                           end if
                        end do
                     else if (n12(i) .eq. 1) then
                        do m = 1, n13(i)
                           mt = type(i13(m,i))
                           if (mt .eq. xtyp) then
                              zaxis(i) = i12(k,i)
                              xaxis(i) = i13(m,i)
                              goto 60
                           end if
                        end do
                     end if
                  end if
               end do
            end do
   60       continue
            if (zaxis(i) .ne. 0) then
               polaxe(i) = mpaxis(imp)
               do j = 1, 13
                  pole(j,i) = multip(j,imp)
               end do
            end if
         end if
      end do
c
c     process keywords with multipole parameters for specific atoms
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:10) .eq. 'MULTIPOLE ') then
            k = 0
            kz = 0
            kx = 0
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=90,end=90)  k,kz,kx,mpl(1)
            if (k.lt.0 .and. k.ge.-n) then
               k = -k
               if (kx .lt. 0)  axt = 'Bisector'
               kz = abs(kz)
               kx = abs(kx)
               record = keyline(i+1)
               read (record,*,err=90,end=90)  (mpl(j),j=2,4)
               record = keyline(i+2)
               read (record,*,err=90,end=90)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=90,end=90)  (mpl(j),j=8,9)
               record = keyline(i+4)
               read (record,*,err=90,end=90)  (mpl(j),j=11,13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Additional Atomic Multipoles',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',8x,'Local Axes Definition',
     &                       10x,'Multipole Moments',/)
               end if
               write (iout,80)  k,kz,kx,axt,(mpl(j),j=1,5),
     &                              mpl(8),mpl(9),(mpl(j),j=11,13)
   80          format (6x,i6,5x,i6,1x,i6,3x,a8,4x,f9.5,/,45x,3f9.5,
     &                       /,45x,f9.5,/,45x,2f9.5,/,45x,3f9.5)
               zaxis(k) = kz
               xaxis(k) = kx
               polaxe(k) = axt
               do j = 1, 13
                  pole(j,k) = mpl(j)
               end do
            end if
   90       continue
         end if
      end do
c
c     convert the dipole and quadrupole moments to Angstroms,
c     quadrupole divided by 3 for Applequist-Dykstra method
c
      do i = 1, n
         do k = 2, 4
            pole(k,i) = pole(k,i) * bohr
         end do
         do k = 5, 13
            pole(k,i) = pole(k,i) * bohr**2 / 3.0d0
         end do
      end do
c
c     get the order of the multipole expansion at each site
c
      do i = 1, n
         size = 0
         do k = 1, 13
            if (pole(k,i) .ne. 0.0d0)  size = max(k,size)
         end do
         if (size .gt. 4) then
            size = 13
         else if (size .gt. 1) then
            size = 4
         end if
         polsiz(i) = size
      end do
c
c     if polarization not used, remove zero and undefined multipoles
c
      if (.not. use_polar) then
         npole = 0
         do i = 1, n
            if (polsiz(i) .ne. 0) then
               if (zaxis(i).ne.0 .and. xaxis(i).ne.0) then
                  npole = npole + 1
                  ipole(npole) = i
                  zaxis(npole) = zaxis(i)
                  xaxis(npole) = xaxis(i)
                  polaxe(npole) = polaxe(i)
                  polsiz(npole) = polsiz(i)
                  do j = 1, 13
                     pole(j,npole) = pole(j,i)
                  end do
               end if
            end if
         end do
c
c     if no atomic multipoles are used, turn off the potential
c
         if (npole .eq. 0)  use_mpole = .false.
      end if
      return
      end
