c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine kdipole  --  assign bond dipole parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "kdipole" assigns bond dipoles to the bonds within
c     the structure and processes any new or changed values
c
c
      subroutine kdipole
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'dipole.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kdipol.i'
      include 'keys.i'
      include 'potent.i'
      include 'ring.i'
      integer i,j,k,m
      integer ia,ib,ic,id
      integer ita,itb
      integer iring,size,next
      real*8 dp,ps
      character*3 pa,pb
      character*6 pt
      character*20 keyword
      character*80 record,string
      logical header,use_ring3
      logical use_ring4,use_ring5
c
c
c     process keywords containing bond dipole parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         iring = -1
         if (keyword(1:7) .eq. 'DIPOLE ')  iring = 0
         if (keyword(1:8) .eq. 'DIPOLE5 ')  iring = 5
         if (keyword(1:8) .eq. 'DIPOLE4 ')  iring = 4
         if (keyword(1:8) .eq. 'DIPOLE3 ')  iring = 3
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.5d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ia,ib,dp,ps
   10       continue
            if (ia.gt.0 .and. ib.gt.0) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Bond Dipole Moment ',
     &                       'Parameters :',
     &                    //,6x,'Atom Types',8x,'Moment',
     &                       6x,'Position',/)
               end if
               if (iring .eq. 0) then
                  write (iout,30)  ia,ib,dp,ps
   30             format (6x,2i4,4x,2f12.3)
               else if (iring .eq. 5) then
                  write (iout,40)  ia,ib,dp,ps
   40             format (6x,2i4,4x,2f12.3,3x,'5-Ring')
               else if (iring .eq. 4) then
                  write (iout,50)  ia,ib,dp,ps
   50             format (6x,2i4,4x,2f12.3,3x,'4-Ring')
               else if (iring .eq. 3) then
                  write (iout,60)  ia,ib,dp,ps
   60             format (6x,2i4,4x,2f12.3,3x,'3-Ring')
               end if
               size = 3
               call numeral (ia,pa,size)
               call numeral (ib,pb,size)
               if (ia .le. ib) then
                  pt = pa//pb
               else
                  pt = pb//pa
               end if
               if (iring .eq. 0) then
                  do j = 1, maxnd
                     if (kd(j).eq.'      ' .or. kd(j).eq.pt) then
                        kd(j) = pt
                        if (ia .le. ib) then
                           dpl(j) = dp
                           pos(j) = ps
                        else
                           dpl(j) = -dp
                           pos(j) = 1.0d0 - ps
                        end if
                        goto 110
                     end if
                  end do
                  write (iout,70)
   70             format (/,' KDIPOLE  --  Too many Bond Dipole',
     &                       ' Moment Parameters')
                  abort = .true.
               else if (iring .eq. 5) then
                  do j = 1, maxnd5
                     if (kd5(j).eq.'      ' .or. kd5(j).eq.pt) then
                        kd5(j) = pt
                        if (ia .le. ib) then
                           dpl5(j) = dp
                           pos5(j) = ps
                        else
                           dpl5(j) = -dp
                           pos5(j) = 1.0d0 - ps
                        end if
                        goto 110
                     end if
                  end do
                  write (iout,80)
   80             format (/,' KDIPOLE  --  Too many 5-Ring Bond',
     &                       ' Dipole Parameters')
                  abort = .true.
               else if (iring .eq. 4) then
                  do j = 1, maxnd4
                     if (kd4(j).eq.'      ' .or. kd4(j).eq.pt) then
                        kd4(j) = pt
                        if (ia .le. ib) then
                           dpl4(j) = dp
                           pos4(j) = ps
                        else
                           dpl4(j) = -dp
                           pos4(j) = 1.0d0 - ps
                        end if
                        goto 110
                     end if
                  end do
                  write (iout,90)
   90             format (/,' KDIPOLE  --  Too many 4-Ring Bond',
     &                       ' Dipole Parameters')
                  abort = .true.
               else if (iring .eq. 3) then
                  do j = 1, maxnd3
                     if (kd3(j).eq.'      ' .or. kd3(j).eq.pt) then
                        kd3(j) = pt
                        if (ia .le. ib) then
                           dpl3(j) = dp
                           pos3(j) = ps
                        else
                           dpl3(j) = -dp
                           pos3(j) = 1.0d0 - ps
                        end if
                        goto 110
                     end if
                  end do
                  write (iout,100)
  100             format (/,' KDIPOLE  --  Too many 3-Ring Bond',
     &                       ' Dipole Parameters')
                  abort = .true.
               end if
            end if
  110       continue
         end if
      end do
c
c     use small rings if present and parameters are available
c
      if (nring3.eq.0 .or. kd3(1).eq.'      ') then
         use_ring3 = .false.
      else
         use_ring3 = .true.
      end if
      if (nring4.eq.0 .or. kd4(1).eq.'      ') then
         use_ring4 = .false.
      else
         use_ring4 = .true.
      end if
      if (nring5.eq.0 .or. kd5(1).eq.'      ') then
         use_ring5 = .false.
      else
         use_ring5 = .true.
      end if
c
c     find and store all the bond dipole moments
c
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = type(ia)
         itb = type(ib)
         size = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
         bdpl(i) = 0.0d0
c
c     make a check for bonds inside small rings
c
         iring = 0
         if (n12(ia).eq.1 .or. n12(ib).eq.1)  goto 120
         if (use_ring3) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               do k = 1, n12(ib)
                  if (ic .eq. i12(k,ib)) then
                     iring = 3
                     goto 120
                  end if
               end do
            end do
         end if
         if (use_ring4) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               if (ic .ne. ib) then
                  do k = 1, n12(ib)
                     id = i12(k,ib)
                     if (id .ne. ia) then
                        do m = 1, n12(ic)
                           if (id .eq. i12(m,ic)) then
                              iring = 4
                              goto 120
                           end if
                        end do
                     end if
                  end do
               end if
            end do
         end if
         if (use_ring5) then
            do j = 1, n13(ia)
               ic = i13(j,ia)
               do k = 1, n13(ib)
                  if (ic .eq. i13(k,ib)) then
                     iring = 5
                     goto 120
                  end if
               end do
            end do
         end if
  120    continue
c
c     try to assign bond dipole parameters for the bond
c
         if (iring .eq. 0) then
            do j = 1, maxnd
               if (kd(j) .eq. '      ')  goto 130
               if (kd(j) .eq. pt) then
                  if (ita .le. itb) then
                     idpl(1,i) = ia
                     idpl(2,i) = ib
                  else
                     idpl(1,i) = ib
                     idpl(2,i) = ia
                  end if
                  bdpl(i) = dpl(j)
                  sdpl(i) = pos(j)
               end if
            end do
  130       continue
         else if (iring .eq. 5) then
            do j = 1, maxnd5
               if (kd5(j) .eq. '      ')  goto 140
               if (kd5(j) .eq. pt) then
                  if (ita .le. itb) then
                     idpl(1,i) = ia
                     idpl(2,i) = ib
                  else
                     idpl(1,i) = ib
                     idpl(2,i) = ia
                  end if
                  bdpl(i) = dpl5(j)
                  sdpl(i) = pos5(j)
               end if
            end do
  140       continue
         else if (iring .eq. 4) then
            do j = 1, maxnd4
               if (kd4(j) .eq. '      ')  goto 150
               if (kd4(j) .eq. pt) then
                  if (ita .le. itb) then
                     idpl(1,i) = ia
                     idpl(2,i) = ib
                  else
                     idpl(1,i) = ib
                     idpl(2,i) = ia
                  end if
                  bdpl(i) = dpl4(j)
                  sdpl(i) = pos4(j)
               end if
            end do
  150       continue
         else if (iring .eq. 3) then
            do j = 1, maxnd3
               if (kd3(j) .eq. '      ')  goto 160
               if (kd3(j) .eq. pt) then
                  if (ita .le. itb) then
                     idpl(1,i) = ia
                     idpl(2,i) = ib
                  else
                     idpl(1,i) = ib
                     idpl(2,i) = ia
                  end if
                  bdpl(i) = dpl3(j)
                  sdpl(i) = pos3(j)
               end if
            end do
  160       continue
         end if
      end do
c
c     process keywords containing bond specific bond dipoles
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'DIPOLE ') then
            ia = 0
            ib = 0
            dp = 0.0d0
            ps = 0.0d0
            string = record(next:80)
            read (string,*,err=170,end=170)  ia,ib,dp,ps
  170       continue
            if (ia.lt.0 .and. ib.lt.0) then
               ia = -ia
               ib = -ib
               if (header) then
                  header = .false.
                  write (iout,180)
  180             format (/,' Additional Bond Dipoles for',
     &                       ' Specific Bonds :',
     &                    //,5x,'Bonded Atoms',7x,'Moment',
     &                          6x,'Position',/)
               end if
               do j = 1, n12(ia)
                  if (i12(j,ia) .eq. ib) then
                     k = bndlist(j,ia)
                     if (ps .eq. 0.0d0)  ps = 0.5d0
                     if (idpl(1,k) .eq. ib) then
                        bdpl(k) = dp
                        sdpl(k) = ps
                     else
                        bdpl(k) = -dp
                        sdpl(k) = 1.0d0 - ps
                     end if
                     write (iout,190)  ia,ib,dp,ps
  190                format (4x,i5,' -',i5,2x,2f12.3)
                     goto 200
                  end if
               end do
            end if
  200       continue
         end if
      end do
c
c     remove zero bond dipoles from the list of dipoles
c
      ndipole = 0
      do i = 1, nbond
         if (bdpl(i) .ne. 0.0d0) then
            ndipole = ndipole + 1
            idpl(1,ndipole) = idpl(1,i)
            idpl(2,ndipole) = idpl(2,i)
            bdpl(ndipole) = bdpl(i)
            sdpl(ndipole) = sdpl(i)
         end if
      end do
c
c     if there are no dipole moments, turn off the potential
c
      if (ndipole .eq. 0) then
         use_dipole = .false.
         use_chgdpl = .false.
      end if
      return
      end
