c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine hybrid  --  set parameters for hybrid system  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "hybrid" constructs the hybrid hamiltonian for a specified
c     initial state, final state and mutation parameter "lambda"
c
c
      subroutine hybrid
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'mutant.i'
c
c
c     set the potential energy parameters for hybrid atoms
c
      if (nhybrid .ne. 0) then
         write (iout,10)  lambda
   10    format (/,' Lambda Coupling Parameter for FEP :',f12.3)
         call hatom
         call hbond
         call hangle
         call hstrbnd
         call himptor
         call htors
         call hstrtor
         call hvdw
         call hcharge
         call hdipole
      end if
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine hatom  --  assign hybrid atom parameters  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "hatom" assigns a new atom type to each hybrid site
c
c
      subroutine hatom
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'mutant.i'
      integer i,k,it,it0,it1,ntype
c
c
c     find the total number of atom types currently used;
c     exclude the "HYB" types so that they can be reused
c
      do i = 1, maxtyp
         if (symbol(i).eq.'   ' .or. symbol(i).eq.'HYB') then
            ntype = i - 1
            goto 10
         end if
      end do
   10 continue
c
c     stop if there are too many atom types required
c
      if (maxtyp .lt. ntype+nhybrid) then
         abort = .true.
         write (iout,20)
   20    format (' HATOM  --  Too many Sites to be Altered;',
     &              ' Increase MAXTYP')
      end if
c
c     create a new atom type for each of the hybrid atoms
c
      do i = 1, nhybrid
         k = ihybrid(i)
         it = ntype + i
         it0 = type0(i)
         it1 = type1(i)
         symbol(it) = 'HYB'
         atmnum(it) = 0
         weight(it) = lambda*weight(it1) + (1.0d0-lambda)*weight(it0)
         ligand(it) = 0
         describe(it) = 'Hybrid Atom Type    '
         type(k) = it
         name(k) = symbol(it)
         atomic(k) = atmnum(it)
         mass(k) = weight(it)
         valence(k) = ligand(it)
         story(k) = describe(it)
      end do
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine hbond  --  find hybrid bond parameters  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "hbond" constructs the hybrid bonded interaction
c     parameters given an initial state, final state and
c     mutation parameter "lambda"
c
c
      subroutine hbond
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'iounit.i'
      include 'inform.i'
      include 'kbonds.i'
      include 'mutant.i'
      integer i,j,k,ia,ib
      integer ita,itb,size
      real*8 bk0,bk1,bl0,bl1
      character*3 pa,pb
      character*6 pt
      logical header
c
c
c     assign the hybrid parameters for individual bonds
c
      header = .true.
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         if (alter(ia) .or. alter(ib)) then
            ita = class(ia)
            itb = class(ib)
c
c     find the bond parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
            end do
            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
            bk0 = 0.0d0
            bl0 = 0.0d0
            do j = 1, maxnb
               if (kb(j) .eq. pt) then
                  bk0 = fcon(j)
                  bl0 = blen(j)
                  goto 10
               end if
            end do
   10       continue
c
c     find the bond parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
            end do
            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
            bk1 = 0.0d0
            bl1 = 0.0d0
            do j = 1, maxnb
               if (kb(j) .eq. pt) then
                  bk1 = fcon(j)
                  bl1 = blen(j)
                  goto 20
               end if
            end do
   20       continue
c
c     form the hybrid parameters for the current bond
c
            if (bl0 .eq. 0.0d0)  bl0 = bl1
            if (bl1 .eq. 0.0d0)  bl1 = bl0
            bk(i) = lambda*bk1 + (1.0d0-lambda)*bk0
            bl(i) = lambda*bl1 + (1.0d0-lambda)*bl0
            if (verbose) then
               if (header) then
                  header = .false.
                  write (iout,30)
   30             format (/,' Hybrid Bond Stretching Parameters :',
     &                    //,6x,'Atom Numbers',9x,'KS',7x,'Length',/)
               end if
               write (iout,40)  ia,ib,bk(i),bl(i)
   40          format (6x,2i5,f14.3,f12.4)
            end if
         end if
      end do
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine hangle  --  find hybrid angle parameters  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "hangle" constructs the hybrid angle bending parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hangle
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'inform.i'
      include 'kangs.i'
      include 'mutant.i'
      integer i,j,k,ia,ib,ic
      integer ita,itb,itc,size
      real*8 acon0,acon1,anat0,anat1
      character*3 pa,pb,pc
      character*9 pt
      logical header
c
c
c     assign the hybrid parameters for individual angles
c
      header = .true.
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (alter(ia) .or. alter(ib) .or. alter(ic)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
c
c     find the angle parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (ita .le. itc) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            acon0 = 0.0d0
            anat0 = 0.0d0
            do j = 1, maxna
               if (ka(j) .eq. pt) then
                  acon0 = con(j)
                  anat0 = ang(1,j)
                  goto 10
               end if
            end do
   10       continue
c
c     find the angle parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            size = 3
            call numeral (ita,pa,3)
            call numeral (itb,pb,3)
            call numeral (itc,pc,3)
            if (ita .le. itc) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            acon1 = 0.0d0
            anat1 = 0.0d0
            do j = 1, maxna
               if (ka(j) .eq. pt) then
                  acon1 = con(j)
                  anat1 = ang(1,j)
                  goto 20
               end if
            end do
   20       continue
c
c     form the hybrid parameters for the current angle
c
            if (anat0 .eq. 0.0d0)  anat0 = anat1
            if (anat1 .eq. 0.0d0)  anat1 = anat0
            acon(i) = lambda*acon1 + (1.0d0-lambda)*acon0
            anat(i) = lambda*anat1 + (1.0d0-lambda)*anat0
            if (verbose) then
               if (header) then
                  header = .false.
                  write (iout,30)
   30             format (/,' Hybrid Angle Bending Parameters :',
     &                    //,6x,'Atom Numbers',9x,'KB',8x,'Angle',/)
               end if
               write (iout,40)  ia,ib,ic,acon(i),anat(i)
   40          format (3x,3i5,2f12.3)
            end if
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine hstrbnd  --  hybrid stretch-bend parameters  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "hstrbnd" constructs the hybrid stretch-bend parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hstrbnd
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'inform.i'
      include 'katoms.i'
      include 'kstbnd.i'
      include 'mutant.i'
      include 'strbnd.i'
      integer i,j,k,ia,ib,ic
      integer ita,itb,itc,nsb
      integer nba,nba0,nba1
      integer nbc,nbc0,nbc1
      real*8 ksb0,ksb1
      logical header
c
c
c     assign hybrid parameters for the stretch-bend sites
c
      header = .true.
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (alter(ia) .or. alter(ib) .or. alter(ic)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            do j = 1, n12(ib)
               if (i12(j,ib) .eq. ia)  nba = bndlist(j,ib)
               if (i12(j,ib) .eq. ic)  nbc = bndlist(j,ib)
            end do
c
c     find the stretch-bend parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            nsb = 1
            nba0 = nba
            nbc0 = nbc
            if (atmnum(ita) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nba0 = 0
            end if
            if (atmnum(itc) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nbc0 = 0
            end if
            ksb0 = stbn(nsb,itb)
c
c     find the stretch-bend parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            nsb = 1
            nba1 = nba
            nbc1 = nbc
            if (atmnum(ita) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nba1 = 0
            end if
            if (atmnum(itc) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nbc1 = 0
            end if
            ksb1 = stbn(nsb,itb)
c
c     form hybrid parameters for the current stretch-bend
c
            ksb(i) = lambda*ksb1 + (1.0d0-lambda)*ksb0
            if (ksb(i) .eq. 0.0d0) then
               if (isb(1,i) .ne. 0) then
                  nstrbnd = nstrbnd - 1
                  isb(1,i) = 0
               end if
            else
               if (isb(1,i) .ne. i) then
                  nstrbnd = nstrbnd + 1
                  isb(1,i) = i
               end if
               isb(2,i) = max(nba0,nba1)
               isb(3,i) = max(nbc0,nbc1)
               if (verbose) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Hybrid Stretch-Bend Parameters :',
     &                       //,6x,'Atom Numbers',9x,'KSB',/)
                  end if
                  write (iout,20)  ia,ib,ic,ksb(i)
   20             format (3x,3i5,f12.3)
               end if
            end if
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine himptor  --  find hybrid improper torsions  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "himptor" constructs the hybrid improper torsional
c     parameters given an initial state, final state and
c     mutation parameter "lambda"
c
c
      subroutine himptor
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'inform.i'
      include 'imptor.i'
      include 'kitors.i'
      include 'mutant.i'
      integer i,j,k,ia,ib,ic,id
      integer ita,itb,itc,itd
      integer it1,it2,it3,size
      real*8 v1_0,v2_0,v3_0,s1_0,s2_0,s3_0
      real*8 v1_1,v2_1,v3_1,s1_1,s2_1,s3_1
      character*3 pb,p1,p2,p3
      character*12 pt
      logical header,used
c
c
c     construct hybrid improper torsion parameters
c
      header = .true.
      do i = 1, n
         if (n12(i) .eq. 3) then
            used = .false.
            ia = i12(1,i)
            ib = i
            ic = i12(2,i)
            id = i12(3,i)
            if (alter(ia) .or. alter(ib) .or.
     &          alter(ic) .or. alter(id)) then
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
c
c     find improper torsion parameters for the initial state
c
               do j = 1, nhybrid
                  k = ihybrid(j)
                  if (k .eq. ia)  ita = class0(j)
                  if (k .eq. ib)  itb = class0(j)
                  if (k .eq. ic)  itc = class0(j)
                  if (k .eq. id)  itd = class0(j)
               end do
               it1 = min(ita,itc,itd)
               it2 = max(min(ita,itc),min(ita,itd),min(itc,itd))
               it3 = max(ita,itc,itd)
               size = 3
               call numeral (itb,pb,size)
               call numeral (it1,p1,size)
               call numeral (it2,p2,size)
               call numeral (it3,p3,size)
               pt = pb//p1//p2//p3
               v1_0 = 0.0d0
               s1_0 = 0.0d0
               v2_0 = 0.0d0
               s2_0 = 0.0d0
               v3_0 = 0.0d0
               s3_0 = 0.0d0
               do j = 1, maxnti
                  if (kti(j) .eq. pt) then
                     used = .true.
                     v1_0 = ti1(1,j)
                     s1_0 = ti1(2,j)
                     v2_0 = ti2(1,j)
                     s2_0 = ti2(2,j)
                     v3_0 = ti3(1,j)
                     s3_0 = ti3(2,j)
                     goto 10
                  end if
               end do
   10          continue
c
c     find improper torsion parameters for the final state
c
               do j = 1, nhybrid
                  k = ihybrid(j)
                  if (k .eq. ia)  ita = class1(j)
                  if (k .eq. ib)  itb = class1(j)
                  if (k .eq. ic)  itc = class1(j)
                  if (k .eq. id)  itd = class1(j)
               end do
               it1 = min(ita,itc,itd)
               it2 = max(min(ita,itc),min(ita,itd),min(itc,itd))
               it3 = max(ita,itc,itd)
               size = 3
               call numeral (itb,pb,size)
               call numeral (it1,p1,size)
               call numeral (it2,p2,size)
               call numeral (it3,p3,size)
               pt = pb//p1//p2//p3
               v1_1 = 0.0d0
               s1_1 = 0.0d0
               v2_1 = 0.0d0
               s2_1 = 0.0d0
               v3_1 = 0.0d0
               s3_1 = 0.0d0
               do j = 1, maxnti
                  if (kti(j) .eq. pt) then
                     used = .true.
                     v1_1 = ti1(1,j)
                     s1_1 = ti1(2,j)
                     v2_1 = ti2(1,j)
                     s2_1 = ti2(2,j)
                     v3_1 = ti3(1,j)
                     s3_1 = ti3(2,j)
                     goto 20
                  end if
               end do
   20          continue
            end if
c
c     form hybrid parameters for the current improper torsion
c
            if (used) then
               do j = 1, nitors
                  if (iitors(2,j) .eq. ib) then
                     k = j
                     goto 30
                  end if
               end do
               nitors = nitors + 1
               k = nitors
   30          continue
               iitors(1,k) = ia
               iitors(2,k) = ib
               iitors(3,k) = ic
               iitors(4,k) = id
               if (s1_0 .eq. 0.0d0)  s1_0 = s1_1
               if (s2_0 .eq. 0.0d0)  s2_0 = s2_1
               if (s3_0 .eq. 0.0d0)  s3_0 = s3_1
               if (s1_1 .eq. 0.0d0)  s1_1 = s1_0
               if (s2_1 .eq. 0.0d0)  s2_1 = s2_0
               if (s3_1 .eq. 0.0d0)  s3_1 = s3_0
               itors1(1,k) = lambda*v1_1 + (1.0d0-lambda)*v1_0
               itors1(2,k) = lambda*s1_1 + (1.0d0-lambda)*s1_0
               itors2(1,k) = lambda*v2_1 + (1.0d0-lambda)*v2_0
               itors2(2,k) = lambda*s2_1 + (1.0d0-lambda)*s2_0
               itors3(1,k) = lambda*v3_1 + (1.0d0-lambda)*v3_0
               itors3(2,k) = lambda*s3_1 + (1.0d0-lambda)*s3_0
            end if
            if (verbose .and. used) then
               if (header) then
                  header = .false.
                  write (iout,40)
   40             format (/,' Hybrid Improper Torsional Parameters :',
     &                    //,6x,'Atom Numbers',16x,'KIT1',13x,'KIT2',
     &                       13x,'KIT3',/)
               end if
               write (iout,50)  ia,ib,ic,id,itors1(1,k),itors1(2,k),
     &                          itors2(1,k),itors2(2,k),
     &                          itors3(1,k),itors3(2,k)
   50          format (1x,4i5,4x,3(f10.4,f7.3))
            end if
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine htors  --  find hybrid torsion parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "htors" constructs the hybrid torsional parameters for
c     a given initial state, final state, and "lambda" value
c
c
      subroutine htors
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'ktorsn.i'
      include 'mutant.i'
      include 'tors.i'
      integer i,j,k,ia,ib,ic,id
      integer ita,itb,itc,itd,size
      real*8  v1_0,s1_0,v2_0,s2_0,v3_0,s3_0
      real*8  v1_1,s1_1,v2_1,s2_1,v3_1,s3_1
      character*3 pa,pb,pc,pd
      character*12 pt
      logical header
c
c
c     construct hybrid torsional parameters
c
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (alter(ia) .or. alter(ib) .or.
     &       alter(ic) .or. alter(id)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
c
c     find the torsion parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
               if (k .eq. id)  itd = class0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            if (itb .lt. itc) then
               pt = pa//pb//pc//pd
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
            end if
            v1_0 = 0.0d0
            s1_0 = 0.0d0
            v2_0 = 0.0d0
            s2_0 = 0.0d0
            v3_0 = 0.0d0
            s3_0 = 0.0d0
            do j = 1, maxnt
               if (kt(j) .eq. pt) then
                  v1_0 = t1(1,j)
                  s1_0 = t1(2,j)
                  v2_0 = t2(1,j)
                  s2_0 = t2(2,j)
                  v3_0 = t3(1,j)
                  s3_0 = t3(2,j)
                  goto 10
               end if
            end do
   10       continue
c
c     find the torsion parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
               if (k .eq. id)  itd = class1(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            if (itb .lt. itc) then
               pt = pa//pb//pc//pd
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
            end if
            v1_1 = 0.0d0
            s1_1 = 0.0d0
            v2_1 = 0.0d0
            s2_1 = 0.0d0
            v3_1 = 0.0d0
            s3_1 = 0.0d0
            do j = 1, maxnt
               if (kt(j) .eq. pt) then
                  v1_1 = t1(1,j)
                  s1_1 = t1(2,j)
                  v2_1 = t2(1,j)
                  s2_1 = t2(2,j)
                  v3_1 = t3(1,j)
                  s3_1 = t3(2,j)
                  goto 20
               end if
            end do
   20       continue
c
c     form the hybrid parameters for the current torsion
c
            if (s1_0 .eq. 0.0d0)  s1_0 = s1_1
            if (s2_0 .eq. 0.0d0)  s2_0 = s2_1
            if (s3_0 .eq. 0.0d0)  s3_0 = s3_1
            if (s1_1 .eq. 0.0d0)  s1_1 = s1_0
            if (s2_1 .eq. 0.0d0)  s2_1 = s2_0
            if (s3_1 .eq. 0.0d0)  s3_1 = s3_0
            tors1(1,i) = lambda*v1_1 + (1.0d0-lambda)*v1_0
            tors1(2,i) = lambda*s1_1 + (1.0d0-lambda)*s1_0
            tors2(1,i) = lambda*v2_1 + (1.0d0-lambda)*v2_0
            tors2(2,i) = lambda*s2_1 + (1.0d0-lambda)*s2_0
            tors3(1,i) = lambda*v3_1 + (1.0d0-lambda)*v3_0
            tors3(2,i) = lambda*s3_1 + (1.0d0-lambda)*s3_0
            if (verbose) then
               if (header) then
                  header = .false.
                  write (iout,30)
   30             format (/,' Hybrid Torsional Parameters :',
     &                    //,6x,'Atom Numbers',17x,'KT1',14x,'KT2',
     &                       14x,'KT3',/)
               end if
               write (iout,40)  ia,ib,ic,id,tors1(1,i),tors1(2,i),
     &                          tors2(1,i),tors2(2,i),
     &                          tors3(1,i),tors3(2,i)
   40          format (1x,4i5,4x,3(f10.4,f7.3))
            end if
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine hstrtor  --  hybrid stretch-torsion terms  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "hstrtor" constructs the hybrid stretch-torsion parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hstrtor
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'ksttor.i'
      include 'mutant.i'
      include 'strtor.i'
      include 'tors.i'
      integer i,j,k,itb,itc
      integer ia,ib,ic,id,size
      character*3 pb,pc
      character*6 pt
      real*8 kst0(3),kst1(3)
      logical header
c
c
c     assign hybrid parameters for the stretch-torsion sites
c
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (alter(ib) .or. alter(ic)) then
            itb = class(ib)
            itc = class(ic)
c
c     find the stretch-torsion parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            size = 3
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (itb .le. itc) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do k = 1, 3
               kst0(k) = 0.0d0
            end do
            do j = 1, maxnbt
               if (kbt(j) .eq. pt) then
                  do k = 1, 3
                     kst0(k) = btcon(k,j)
                  end do
                  goto 10
               end if
            end do
   10       continue
c
c     find the stretch-torsion parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            size = 3
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (itb .le. itc) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do k = 1, 3
               kst1(k) = 0.0d0
            end do
            do j = 1, maxnbt
               if (kbt(j) .eq. pt) then
                  do k = 1, 3
                     kst1(k) = btcon(k,j)
                  end do
                  goto 20
               end if
            end do
   20       continue
c
c     form hybrid parameters for the current stretch-torsion
c
            do j = 1, 3
               kst(j,i) = lambda*kst1(j) + (1.0d0-lambda)*kst0(j)
            end do
            if (kst(1,i).eq.0.0d0 .and. kst(2,i).eq.0.0d0
     &                  .and. kst(3,i).eq.0.0d0) then
               if (ist(1,i) .ne. 0) then
                  nstrtor = nstrtor - 1
                  ist(1,i) = 0
               end if
            else
               if (ist(1,i) .ne. i) then
                  nstrtor = nstrtor + 1
                  ist(1,i) = i
                  do j = 1, n12(ib)
                     if (i12(j,ib) .eq. ic) then
                        ist(2,i) = bndlist(j,ib)
                        goto 30
                     end if
                  end do
   30             continue
               end if
               if (verbose) then
                  if (header) then
                     header = .false.
                     write (iout,40)
   40                format (/,' Hybrid Stretch-Torsion Parameters :',
     &                       //,6x,'Atom Numbers',13x,'KST1',8x,'KST2',
     &                          8x,'KST3',/)
                  end if
                  write (iout,50)  ia,ib,ic,id,(kst(j,i),j=1,3)
   50             format (3x,4i5,3f12.3)
               end if
            end if
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine hvdw  --  hybrid van der Waals parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "hvdw" constructs the hybrid van der Waals interaction
c     parameters given an initial state, final state and
c     value of the mutation parameter "lambda"
c
c
      subroutine hvdw
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kvdws.i'
      include 'math.i'
      include 'mutant.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,it,it0,it1
      real*8 radius,rd,ep
      real*8 srad(maxtyp),seps(maxtyp)
      logical header
c
c
c     assign the hybrid van der Waals parameters
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         it0 = class0(j)
         it1 = class1(j)
         rad(it) = lambda*rad(it1) + (1.0d0-lambda)*rad(it0)
         eps(it) = lambda*eps(it1) + (1.0d0-lambda)*eps(it0)
      end do
c
c     get the square roots of the vdw radii and well depths
c
      do i = 1, maxtyp
         srad(i) = sqrt(rad(i))
         seps(i) = sqrt(eps(i))
      end do
c
c     use combination rules to set pairwise vdw radii sums
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         do k = 1, maxtyp
            if (rad(it).eq.0.0d0 .and. rad(k).eq.0.0d0) then
               rd = 0.0d0
            else if (radrule(1:10) .eq. 'ARITHMETIC') then
               rd = rad(it) + rad(k)
            else if (radrule(1:9) .eq. 'GEOMETRIC') then
               rd = 2.0d0*(srad(it)*srad(k))
            else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
               rd = 2.0d0*(rad(it)**3+rad(k)**3)/(rad(it)**2+rad(k)**2)
            else
               rd = rad(it) + rad(k)
            end if
            radmin(it,k) = rd
            radmin(k,it) = rd
         end do
      end do
c
c     use combination rules to set pairwise well depths
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         do k = 1, maxtyp
            if (eps(it).eq.0.0d0 .and. eps(k).eq.0.0d0) then
               ep = 0.0d0
            else if (epsrule(1:10) .eq. 'ARITHMETIC') then
               ep = 0.5d0 * (eps(it) + eps(k))
            else if (epsrule(1:9) .eq. 'GEOMETRIC') then
               ep = seps(it) * seps(k)
            else if (epsrule(1:8) .eq. 'HARMONIC') then
               ep = 2.0d0 * (eps(it)*eps(k)) / (eps(it)+eps(k))
            else if (epsrule(1:3) .eq. 'HHG') then
               ep = 4.0d0 * (eps(it)*eps(k)) / (seps(it)+seps(k))**2
            else
               ep = seps(it) * seps(k)
            end if
            epsilon(it,k) = ep
            epsilon(k,it) = ep
         end do
      end do
c
c     print the van der Waals parameters for hybrid atoms
c
      header = .true.
      do j = 1, nhybrid
         if (verbose) then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Hybrid van der Waals Parameters :',
     &                 //,7x,'Atom Number    Radius     Epsilon')
            end if
            radius = rad(it)
            if (radsiz .eq. 'DIAMETER')  radius = 2.0d0 * radius
            if (radtyp .eq. 'SIGMA')  radius = radius / twosix
            write (iout,20)  i,radius,eps(it)
   20       format (6x,i8,f14.4,f12.4)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hcharge  --  find hybrid charge parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hcharge" constructs the hybrid charge interaction energy
c     parameters given an initial state, final state and "lambda"
c
c
      subroutine hcharge
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kchrge.i'
      include 'mutant.i'
      integer i,j,k,it,it0,it1
      real*8 chg0,chg1,hybchg
      logical header,used
c
c
c     assign the hybrid parameters for atomic charges
c
      header = .true.
      do j = 1, nhybrid
         used = .false.
         i = ihybrid(j)
         it = type(i)
         it0 = type0(j)
         it1 = type1(j)
         chg0 = chg(it0)
         chg1 = chg(it1)
         hybchg = lambda*chg1 + (1.0d0-lambda)*chg0
         do k = 1, nion
            if (iion(k) .eq. i) then
               used = .true.
               pchg(k) = hybchg
               goto 10
            end if
         end do
         if (chg0.ne.0.0d0 .or. chg1.ne.0.0d0) then
            used = .true.
            nion = nion + 1
            iion(nion) = i
            kion(nion) = i
            pchg(nion) = hybchg
         end if
   10    continue
         if (verbose .and. used) then
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Hybrid Atomic Partial Charge Parameters :',
     &                 //,7x,'Atom Number',7x,'Charge',/)
            end if
            write (iout,30)  i,hybchg
   30       format (6x,i8,5x,f12.3)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hdipole  --  find hybrid dipole parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hdipole" constructs the hybrid dipole interaction energy
c     parameters given an initial state, final state and "lambda"
c
c
      subroutine hdipole
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'dipole.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kdipol.i'
      include 'mutant.i'
      integer i,j,k,ia,ib
      integer ita,itb,size
      character*3 pa,pb
      character*6 blank,pt
      real*8 dpl0,dpl1,hybdpl
      real*8 pos0,pos1,hybpos
      logical header,used
      data blank  / '      ' /
c
c
c     assign the hybrid parameters for bond dipoles
c
      header = .true.
      do i = 1, nbond
         ia = ibnd(1,i)
         ib = ibnd(2,i)
         if (alter(ia) .or. alter(ib)) then
            ita = type(ia)
            itb = type(ib)
c
c     find the dipole parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = type0(j)
               if (k .eq. ib)  itb = type0(j)
            end do
            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
            dpl0 = 0.0d0
            pos0 = 0.5d0
            do j = 1, maxnd
               if (kd(j) .eq. blank)  goto 10
               if (kd(j) .eq. pt) then
                  if (ita .le. itb) then
                     dpl0 = bdpl(j)
                     pos0 = sdpl(j)
                  else
                     dpl0 = -bdpl(j)
                     pos0 = 1.0d0 - sdpl(j)
                  end if
               end if
            end do
   10       continue
c
c     find the dipole parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = type1(j)
               if (k .eq. ib)  itb = type1(j)
            end do
            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
            dpl1 = 0.0d0
            pos1 = 0.5d0
            do j = 1, maxnd
               if (kd(j) .eq. blank)  goto 20
               if (kd(j) .eq. pt) then
                  if (ita .le. itb) then
                     dpl1 = bdpl(j)
                     pos1 = sdpl(j)
                  else
                     dpl1 = -bdpl(j)
                     pos1 = 1.0d0 - sdpl(j)
                  end if
               end if
            end do
   20       continue
c
c     form the hybrid parameters for the current dipole
c
            hybdpl = lambda*dpl1 + (1.0d0-lambda)*dpl0
            hybpos = lambda*pos1 + (1.0d0-lambda)*pos0
            used = .false.
            do j = 1, ndipole
               if ((idpl(1,j).eq.ia .and. idpl(2,j).eq.ib) .or.
     &             (idpl(1,j).eq.ib .and. idpl(2,j).eq.ia)) then
                  idpl(1,j) = ia
                  idpl(2,j) = ib
                  bdpl(j) = hybdpl
                  sdpl(j) = hybpos
                  used = .true.
                  goto 30
               end if
            end do
            if (hybdpl .ne. 0.0d0) then
               ndipole = ndipole + 1
               idpl(1,ndipole) = ia
               idpl(2,ndipole) = ib
               bdpl(ndipole) = hybdpl
               sdpl(ndipole) = hybpos
               used = .true.
            end if
   30       continue
            if (verbose .and. used) then
               if (header) then
                  header = .false.
                  write (iout,40)
   40             format (/,' Hybrid Bond Dipole Moment Parameters :',
     &                    //,6x,'Atom Numbers',7x,'Moment',
     &                       7x,'Position',/)
               end if
               write (iout,50)  ia,ib,hybdpl,hybpos
   50          format (6x,2i5,2f15.3)
            end if
         end if
      end do
      return
      end
