c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #######################################################
c     ##                                                   ##
c     ##  subroutine kbond  --  bond parameter assignment  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "kbond" assigns a force constant and ideal bond length
c     to each bond in the structure and processes any new or
c     changed parameter values
c
c
      subroutine kbond
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kbonds.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 fc,bd,edb
      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 stretching 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:5) .eq. 'BOND ')  iring = 0
         if (keyword(1:6) .eq. 'BOND5 ')  iring = 5
         if (keyword(1:6) .eq. 'BOND4 ')  iring = 4
         if (keyword(1:6) .eq. 'BOND3 ')  iring = 3
         if (iring .ge. 0) then
            ia = 0
            ib = 0
            fc = 0.0d0
            bd = 0.0d0
            edb = -1.d0
            string = record(next:80)
c jcc       read (string,*,err=10,end=10)  ia,ib,fc,bd
            read (string,*,err=10,end=10)  ia,ib,fc,bd,edb
c jcc
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Bond Stretching Parameters :',
     &                 //,5x,'Atom Classes',9x,'K(S)',6x,'Length',/)
            end if
            if (iring .eq. 0) then
c jcc
               write (iout,30)  ia,ib,fc,bd,edb
   30          format (6x,2i4,4x,f12.3,f12.4,f12.4)
            else if (iring .eq. 5) then
               write (iout,40)  ia,ib,fc,bd,edb
   40          format (6x,2i4,4x,f12.3,f12.4,f12.4,3x,'5-Ring')
            else if (iring .eq. 4) then
               write (iout,50)  ia,ib,fc,bd,edb
   50          format (6x,2i4,4x,f12.3,f12.4,f12.4,3x,'4-Ring')
            else if (iring .eq. 3) then
               write (iout,60)  ia,ib,fc,bd,edb
   60          format (6x,2i4,4x,f12.3,f12.4,3x,f12.4,'3-Ring')
c jcc
            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, maxnb
                  if (kb(j).eq.'      ' .or. kb(j).eq.pt) then
                     kb(j) = pt
                     fcon(j) = fc
                     blen(j) = bd
                     ebd(j) = edb
                     goto 80
                  end if
               end do
               write (iout,70)
   70          format (/,' KBOND   --  Too many Bond Stretching',
     &                       ' Parameters')
               abort = .true.
   80          continue
            else if (iring .eq. 5) then
               do j = 1, maxnb5
                  if (kb5(j).eq.'      ' .or. kb5(j).eq.pt) then
                     kb5(j) = pt
                     fcon5(j) = fc
                     blen5(j) = bd
                     ebd5(j) = edb
                     goto 100
                  end if
               end do
               write (iout,90)
   90          format (/,' KBOND   --  Too many 5-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
  100          continue
            else if (iring .eq. 4) then
               do j = 1, maxnb4
                  if (kb4(j).eq.'      ' .or. kb4(j).eq.pt) then
                     kb4(j) = pt
                     fcon4(j) = fc
                     blen4(j) = bd
                     ebd4(j) = edb
                     goto 120
                  end if
               end do
               write (iout,110)
  110          format (/,' KBOND   --  Too many 4-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
  120          continue
            else if (iring .eq. 3) then
               do j = 1, maxnb3
                  if (kb3(j).eq.'      ' .or. kb3(j).eq.pt) then
                     kb3(j) = pt
                     fcon3(j) = fc
                     blen3(j) = bd
                     ebd3(j) = edb
                     goto 140
                  end if
               end do
               write (iout,130)
  130          format (/,' KBOND   --  Too many 3-Ring Stretching',
     &                       ' Parameters')
               abort = .true.
  140          continue
            end if
         end if
      end do
c
c     use small rings if present and parameters are available
c
      if (nring3.eq.0 .or. kb3(1).eq.'      ') then
         use_ring3 = .false.
      else
         use_ring3 = .true.
      end if
      if (nring4.eq.0 .or. kb4(1).eq.'      ') then
         use_ring4 = .false.
      else
         use_ring4 = .true.
      end if
      if (nring5.eq.0 .or. kb5(1).eq.'      ') then
         use_ring5 = .false.
      else
         use_ring5 = .true.
      end if
c
c     assign bond length and force constant for each bond
c
      header = .true.
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         ita = class(ia)
         itb = class(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
         bk(i) = 0.0d0
         bl(i) = 0.0d0
         bde(i) = 0.d0
c
c     make a check for bonds inside small rings
c
         iring = 0
         if (n12(ia).eq.1 .or. n12(ib).eq.1)  goto 150
         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 150
                  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 150
                           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 150
                  end if
               end do
            end do
         end if
  150    continue
c
c     assign bond stretching parameters for each bond
c
         if (iring .eq. 0) then
            do j = 1, maxnb
               if (kb(j) .eq. pt) then
                  bk(i) = fcon(j)
                  bl(i) = blen(j)
                  bde(i) = ebd(j)
                  goto 180
               end if
            end do
            if (atomic(ia).ne.0 .and. atomic(ib).ne.0) then
               abort = .true.
               if (header) then
                  header = .false.
                  write (iout,160)
  160             format (/,' Undefined Bond Stretching Parameters :',
     &                    //,' Type',13x,'Atom Names',11x,
     &                       'Atom Classes',/)
               end if
               write (iout,170)  ia,name(ia),ib,name(ib),ita,itb
  170          format (' Bond',7x,i6,'-',a3,i6,'-',a3,7x,2i5)
            end if
  180       continue
c
c     assign stretching parameters for 5-membered ring bonds
c
         else if (iring .eq. 5) then
            do j = 1, maxnb5
               if (kb5(j) .eq. pt) then
                  bk(i) = fcon5(j)
                  bl(i) = blen5(j)
                  bde(i) = ebd5(j)
                  goto 210
               end if
            end do
            if (atomic(ia).ne.0 .and. atomic(ib).ne.0) then
               abort = .true.
               if (header) then
                  header = .false.
                  write (iout,190)
  190             format (/,' Undefined Bond Stretching Parameters :',
     &                    //,' Type',13x,'Atom Names',11x,
     &                       'Atom Classes',/)
               end if
               write (iout,200)  ia,name(ia),ib,name(ib),ita,itb
  200          format (' 5-Ring',5x,i6,'-',a3,i6,'-',a3,7x,2i5)
            end if
  210       continue
c
c     assign stretching parameters for 4-membered ring bonds
c
         else if (iring .eq. 4) then
            do j = 1, maxnb4
               if (kb4(j) .eq. pt) then
                  bk(i) = fcon4(j)
                  bl(i) = blen4(j)
                  bde(i) = ebd4(j)
                  goto 240
               end if
            end do
            if (atomic(ia).ne.0 .and. atomic(ib).ne.0) then
               abort = .true.
               if (header) then
                  header = .false.
                  write (iout,220)
  220             format (/,' Undefined Bond Stretching Parameters :',
     &                    //,' Type',13x,'Atom Names',11x,
     &                       'Atom Classes',/)
               end if
               write (iout,230)  ia,name(ia),ib,name(ib),ita,itb
  230          format (' 4-Ring',5x,i6,'-',a3,i6,'-',a3,7x,2i5)
            end if
  240       continue
c
c     assign stretching parameters for 5-membered ring bonds
c
         else if (iring .eq. 3) then
            do j = 1, maxnb3
               if (kb5(j) .eq. pt) then
                  bk(i) = fcon3(j)
                  bl(i) = blen3(j)
                  bde(i) = ebd3(j)
                  goto 270
               end if
            end do
            if (atomic(ia).ne.0 .and. atomic(ib).ne.0) then
               abort = .true.
               if (header) then
                  header = .false.
                  write (iout,250)
  250             format (/,' Undefined Bond Stretching Parameters :',
     &                    //,' Type',13x,'Atom Names',11x,
     &                       'Atom Classes',/)
               end if
               write (iout,260)  ia,name(ia),ib,name(ib),ita,itb
  260          format (' 3-Ring',5x,i6,'-',a3,i6,'-',a3,7x,2i5)
            end if
  270       continue
         end if
      end do
c
c     if no bond stretches are used, turn off the potential
c
      if (nbond .eq. 0)  use_bond = .false.
      return
      end
