      subroutine gtbpar(istat,i1,i2,bl,bk)
      implicit double precision (a-h,o-z), integer (i-n)
      integer*2 i1, i2
      parameter (mxbnd=82)
      integer bndcon
      common /bndpar/ bndcon(2,mxbnd),bnd(2,mxbnd)
      parameter (mxamb=701)
      integer ambcls
      common /typpar/ ambchg(mxamb),ambcls(mxamb)
      parameter (mxcls=49)
      common /clspar/ ambvdwr(mxcls),ambvdwe(mxcls),mapagf(mxcls)
      logical doamb, dogaff
      parameter (mxgff=71)
      parameter (mxgbnd=746)
      integer gfbcon
      common /gfbpar/ gfbnd(2,mxgbnd),gfbcon(2,mxgbnd)
      
      istat = 0
      doamb = .false.
      dogaff = .false.

      if (i1.gt.0.and.i2.gt.0) then
         doamb = .true.
      elseif (i1.lt.0.or.i2.lt.0) then
         dogaff = .true.
      endif

      if (doamb) then
         iac = ambcls(i1)
         ibc = ambcls(i2)

         do k=1,mxbnd 
            if (
     &       (iac.eq.bndcon(1,k).and.ibc.eq.bndcon(2,k))
     &          .or.
     &       (ibc.eq.bndcon(1,k).and.iac.eq.bndcon(2,k))
     &      ) then
               istat = 1
               bl = bnd(2,k)
               bk = bnd(1,k)
            endif
         end do
      endif

      if (dogaff) then

         if (i1.gt.0) then
            iac = mapagf(ambcls(i1))
         else
            iac = abs(i1)
         endif
         if (i2.gt.0) then
            ibc = mapagf(ambcls(i2))
         else
            ibc = abs(i2)
         endif

         do k=1,mxgbnd 
            if (
     &       (iac.eq.gfbcon(1,k).and.ibc.eq.gfbcon(2,k))
     &          .or.
     &       (ibc.eq.gfbcon(1,k).and.iac.eq.gfbcon(2,k))
     &      ) then
               istat = 1
               bl = gfbnd(2,k)
               bk = gfbnd(1,k)
            endif
         end do
      endif

      return
      end

      subroutine bndard(istat,nbnd,ibnd,bl,bk,maxbnd,iconn,ityp)
c
c     create bond list from the connection array and assign parameters
c
      implicit double precision (a-h,o-z), integer (i-n)
      parameter (mxcon=10)
      common /athlp/  iatoms, mxnat
      parameter (mxbnd=82)
      integer bndcon
      common /bndpar/ bndcon(2,mxbnd),bnd(2,mxbnd)
      parameter (mxamb=701)
      integer ambcls
      common /typpar/ ambchg(mxamb),ambcls(mxamb)
      common /rdwr/ iun1,iun2,iun3,iun4,iun5
      integer*2 ityp
      dimension iconn(mxcon+1,*),ityp(*),
     &          ibnd(2,*),bl(*),bk(*)

      nbnd = 0
      istat = 1

      do i=1,iatoms
         do j=1,iconn(1,i)
            jj = iconn(j+1,i)
            if (jj.gt.0) then
               if (i.lt.jj) then
                  if (nbnd.lt.maxbnd) then
                     nbnd = nbnd + 1
                     ibnd(1,nbnd) = i
                     ibnd(2,nbnd) = jj
                     call gtbpar(istat,
     &                    ityp(i),ityp(jj),bl(nbnd),bk(nbnd))
                     if (istat.eq.0) write(iun5,*) 
     &                       'Missing Bond parameter: ',
     &                               abs(ityp(i)),abs(ityp(jj))
                  else
                     istat = 0
                  endif
               endif
            endif
         end do
      end do

      return
      end

      subroutine bond(eb,nbnd,ibnd,bl,bk,coo,forces)
      implicit double precision (a-h,o-z), integer (i-n)
      common /athlp/  iatoms, mxnat
      dimension ibnd(2,*), bl(*), bk(*), coo(3,*), forces(3,*)
      dimension vab(3)

      eb = 0.0d0

      do i = 1, nbnd
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         bopt = bl(i)
         fk = bk(i)

            do j=1,3
               vab(j) = coo(j,ia) - coo(j,ib)
            end do

            rab = vlen(vab)
            dt = rab - bopt

            dt2 = dt * dt
            e = fk * dt2 
            deddt = 2.0d0 * fk * dt

            de = deddt / rab

            call vscal(vab,3,de)

            eb = eb + e
          
            do j=1,3
               forces(j,ia) = forces(j,ia) + vab(j)
               forces(j,ib) = forces(j,ib) - vab(j)
            end do

      end do

      return
      end
