c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eimptor1  --  impr. torsion energy & gradient  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "eimptor1" calculates improper torsional energy and its
c     first derivatives with respect to Cartesian coordinates
c
c
      subroutine eimptor1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bath.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'imptor.i'
      include 'torpot.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib,ic,id
      real*8 e,dedphi,fgrp
      real*8 v1,v2,v3
      real*8 c1,c2,c3
      real*8 s1,s2,s3
      real*8 cosine,cosine2,cosine3
      real*8 sine,sine2,sine3
      real*8 phi1,phi2,phi3
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xid,yid,zid
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb,rcb
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca
      real*8 xdb,ydb,zdb
      real*8 xt,yt,zt,rt2
      real*8 xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 dphi1,dphi2,dphi3
      real*8 dphidxt,dphidyt,dphidzt
      real*8 dphidxu,dphidyu,dphidzu
      real*8 dphidxia,dphidyia,dphidzia
      real*8 dphidxib,dphidyib,dphidzib
      real*8 dphidxic,dphidyic,dphidzic
      real*8 dphidxid,dphidyid,dphidzid
      real*8 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      logical proceed
c
c
c     zero out energy and first derivative components
c
      eit = 0.0d0
      do i = 1, n
         deit(1,i) = 0.0d0
         deit(2,i) = 0.0d0
         deit(3,i) = 0.0d0
      end do
c
c     calculate the improper torsional angle energy term
c
      do i = 1, nitors
         ia = iitors(1,i)
         ib = iitors(2,i)
         ic = iitors(3,i)
         id = iitors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xt = yba*zcb - ycb*zba
            yt = zba*xcb - zcb*xba
            zt = xba*ycb - xcb*yba
            xu = ycb*zdc - ydc*zcb
            yu = zcb*xdc - zdc*xcb
            zu = xcb*ydc - xdc*ycb
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the improper torsional parameters for this angle
c
               v1 = itors1(1,i)
               c1 = itors1(3,i)
               s1 = itors1(4,i)
               v2 = itors2(1,i)
               c2 = itors2(3,i)
               s2 = itors2(4,i)
               v3 = itors3(1,i)
               c3 = itors3(3,i)
               s3 = itors3(4,i)
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               cosine3 = cosine*cosine2 - sine*sine2
               sine3 = cosine*sine2 + sine*cosine2
               phi1 = 1.0d0 + (cosine*c1 + sine*s1)
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
               phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
               dphi1 = (cosine*s1 - sine*c1)
               dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
               dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
c
c     calculate improper torsion energy and master chain rule term
c
               e = torsunit * (v1*phi1+v2*phi2+v3*phi3)
               dedphi = torsunit * (v1*dphi1+v2*dphi2+v3*dphi3)
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  dedphi = dedphi * fgrp
               end if
c
c     abbreviations for first derivative chain rule terms
c
               xca = xic - xia
               yca = yic - yia
               zca = zic - zia
               xdb = xid - xib
               ydb = yid - yib
               zdb = zid - zib
               dphidxt = (yt*zcb - ycb*zt) / (rt2*rcb)
               dphidyt = (zt*xcb - zcb*xt) / (rt2*rcb)
               dphidzt = (xt*ycb - xcb*yt) / (rt2*rcb)
               dphidxu = -(yu*zcb - ycb*zu) / (ru2*rcb)
               dphidyu = -(zu*xcb - zcb*xu) / (ru2*rcb)
               dphidzu = -(xu*ycb - xcb*yu) / (ru2*rcb)
c
c     chain rule terms for first derivative components
c
               dphidxia = zcb*dphidyt - ycb*dphidzt
               dphidyia = xcb*dphidzt - zcb*dphidxt
               dphidzia = ycb*dphidxt - xcb*dphidyt
               dphidxib = yca*dphidzt - zca*dphidyt
     &                       + zdc*dphidyu - ydc*dphidzu
               dphidyib = zca*dphidxt - xca*dphidzt
     &                       + xdc*dphidzu - zdc*dphidxu
               dphidzib = xca*dphidyt - yca*dphidxt
     &                       + ydc*dphidxu - xdc*dphidyu
               dphidxic = zba*dphidyt - yba*dphidzt
     &                       + ydb*dphidzu - zdb*dphidyu
               dphidyic = xba*dphidzt - zba*dphidxt
     &                       + zdb*dphidxu - xdb*dphidzu
               dphidzic = yba*dphidxt - xba*dphidyt
     &                       + xdb*dphidyu - ydb*dphidxu
               dphidxid = zcb*dphidyu - ycb*dphidzu
               dphidyid = xcb*dphidzu - zcb*dphidxu
               dphidzid = ycb*dphidxu - xcb*dphidyu
c
c     compute first derivative components for this angle
c
               dedxia = dedphi * dphidxia
               dedyia = dedphi * dphidyia
               dedzia = dedphi * dphidzia
               dedxib = dedphi * dphidxib
               dedyib = dedphi * dphidyib
               dedzib = dedphi * dphidzib
               dedxic = dedphi * dphidxic
               dedyic = dedphi * dphidyic
               dedzic = dedphi * dphidzic
               dedxid = dedphi * dphidxid
               dedyid = dedphi * dphidyid
               dedzid = dedphi * dphidzid
c
c     increment the improper torsion energy and gradient
c
               eit = eit + e
               deit(1,ia) = deit(1,ia) + dedxia
               deit(2,ia) = deit(2,ia) + dedyia
               deit(3,ia) = deit(3,ia) + dedzia
               deit(1,ib) = deit(1,ib) + dedxib
               deit(2,ib) = deit(2,ib) + dedyib
               deit(3,ib) = deit(3,ib) + dedzib
               deit(1,ic) = deit(1,ic) + dedxic
               deit(2,ic) = deit(2,ic) + dedyic
               deit(3,ic) = deit(3,ic) + dedzic
               deit(1,id) = deit(1,id) + dedxid
               deit(2,id) = deit(2,id) + dedyid
               deit(3,id) = deit(3,id) + dedzid
c
c     increment the components of the virial
c
               if (isobaric) then
                  virx = virx - xba*dedxia + xdc*dedxid
     &                      + xcb*(dedxic+dedxid)
                  viry = viry - yba*dedyia + ydc*dedyid
     &                      + ycb*(dedyic+dedyid)
                  virz = virz - zba*dedzia + zdc*dedzid
     &                      + zcb*(dedzic+dedzid)
               end if
            end if
         end if
      end do
      return
      end
